From 9a7920d1b8dde1c5653a613ab0e5f90b01cffcf2 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 18 Oct 2022 01:49:05 +0100 Subject: [PATCH 1/6] Ease restrictions on static members and static let in union and record types --- src/Compiler/Checking/CheckDeclarations.fs | 515 ++++++++++-------- .../Checking/CheckIncrementalClasses.fs | 236 ++++---- .../Checking/CheckIncrementalClasses.fsi | 48 +- src/Compiler/Checking/NicePrint.fs | 26 +- src/Compiler/Checking/PostInferenceChecks.fs | 4 +- src/Compiler/Checking/SignatureConformance.fs | 42 +- src/Compiler/CodeGen/IlxGen.fs | 76 +-- .../Service/SemanticClassification.fs | 16 +- .../Service/ServiceDeclarationLists.fs | 6 +- src/Compiler/Symbols/Symbols.fs | 2 +- src/Compiler/TypedTree/TypedTree.fs | 89 +-- src/Compiler/TypedTree/TypedTree.fsi | 34 +- src/Compiler/TypedTree/TypedTreeOps.fs | 32 +- src/Compiler/TypedTree/TypedTreePickle.fs | 103 +++- 14 files changed, 723 insertions(+), 506 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index c4c2798a2df..ec97a756d23 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -181,12 +181,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 @@ -727,23 +729,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 @@ -756,14 +764,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. @@ -775,12 +789,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 @@ -835,15 +854,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 @@ -854,30 +872,44 @@ module MutRecBindingChecking = error(Error(FSComp.SR.tcEnumerationsMayNotHaveMembers(), (trimRangeToLine m))) match classMemberDef, containerInfo with - | SynMemberDefn.ImplicitCtor (vis, Attributes attrs, SynSimplePats.SimplePats(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)) | _ -> () @@ -891,14 +923,14 @@ 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)) + //if isStatic && Option.isNone incrCtorInfoOpt 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 @@ -915,7 +947,7 @@ module MutRecBindingChecking = | _ -> () let envForMember = - match incrClassCtorLhsOpt with + match incrCtorInfoOpt with | None -> AddDeclaredTypars CheckForDuplicateTypars copyOfTyconTypars envForTycon | Some _ -> envForTycon @@ -924,12 +956,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 @@ -1059,18 +1091,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) -> @@ -1085,7 +1132,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) -> @@ -1210,14 +1257,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 @@ -1234,6 +1284,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 @@ -1253,7 +1304,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 = @@ -1294,17 +1345,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 @@ -1327,7 +1382,7 @@ module MutRecBindingChecking = mkDebugPoint tcref.Range inheritsExpr else inheritsExpr - inheritsExpr, false, None, defnCs + Some (incrCtorInfo, inheritsExpr, false), defnCs let envForTycon = MakeInnerEnvForTyconRef envForDecls tcref false @@ -1349,7 +1404,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 @@ -1359,25 +1414,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 = @@ -1536,7 +1593,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 = @@ -1586,8 +1643,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 | _ -> () ] @@ -1681,16 +1738,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 _ @@ -1699,16 +1763,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 @@ -1718,19 +1782,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 = @@ -2283,11 +2347,10 @@ 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, ecref, envMutRec - - /// Bind type definitions /// /// We first establish the cores of a set of type definitions (i.e. everything @@ -2637,10 +2700,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 @@ -2670,7 +2731,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) @@ -2686,21 +2747,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 @@ -3206,9 +3256,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 @@ -3275,7 +3323,7 @@ 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 repr = TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpRecord) repr, None, NoSafeInitInfo | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly (s, _) -> @@ -3408,8 +3456,9 @@ module EstablishTypeDefinitionCores = let safeInitFields = match safeInitInfo with SafeInitField (_, fld) -> [fld] | NoSafeInitInfo -> [] let repr = - TFSharpObjectRepr - { fsobjmodel_kind = kind + TFSharpTyconRepr + { fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind = kind fsobjmodel_vslots = abstractSlots fsobjmodel_rfields = Construct.MakeRecdFieldsTable (userFields @ implicitStructFields @ safeInitFields) } repr, baseValOpt, safeInitInfo @@ -3430,8 +3479,9 @@ module EstablishTypeDefinitionCores = writeFakeRecordFieldsToSink fields' let repr = - TFSharpObjectRepr - { fsobjmodel_kind=kind + TFSharpTyconRepr + { fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind=kind fsobjmodel_vslots=[] fsobjmodel_rfields= Construct.MakeRecdFieldsTable (vfld :: fields') } repr, None, NoSafeInitInfo @@ -3732,7 +3782,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 = @@ -3986,6 +4036,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. /// @@ -3995,121 +4155,27 @@ 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 (x, y, _) -> Some(x, y) | _ -> None) + let slotsigs = members |> List.choose (function SynMemberDefn.AbstractSlot (x, 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 = { 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 + let members = SplitAutoProps members let isConcrete = members |> List.exists (function @@ -4151,6 +4217,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/CheckIncrementalClasses.fs b/src/Compiler/Checking/CheckIncrementalClasses.fs index 893cdc4e193..1befa8ec6ba 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fs +++ b/src/Compiler/Checking/CheckIncrementalClasses.fs @@ -35,20 +35,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 @@ -71,20 +83,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 = @@ -139,26 +177,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 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 - let thisVal = // --- Create this for use inside constructor let thisId = ident ("this", m) @@ -166,18 +184,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() } @@ -256,13 +269,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, @@ -271,7 +286,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 = @@ -282,7 +297,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 @@ -326,7 +341,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 @@ -336,10 +351,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 = @@ -360,9 +378,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 @@ -448,8 +466,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 @@ -458,7 +476,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,7 +492,7 @@ type IncrClassReprInfo = 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} + tcref.Deref.entity_tycon_repr <- TFSharpTyconRepr { tcref.FSharpTyconRepresentationData with fsobjmodel_rfields = recdFields} /// Given localRep saying how locals have been represented, e.g. as fields. @@ -533,25 +551,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, @@ -561,15 +567,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 @@ -624,7 +645,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) @@ -634,13 +658,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, _) -> @@ -658,8 +685,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 @@ -681,14 +711,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 @@ -714,7 +744,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", @@ -733,7 +763,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 @@ -754,11 +784,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) ] @@ -769,10 +802,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) @@ -801,7 +837,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 @@ -815,7 +855,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 // // @@ -840,7 +883,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. // @@ -854,7 +897,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 @@ -872,9 +915,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 @@ -882,11 +925,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..2ed5c559d80 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,17 @@ 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 +144,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 +152,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 +161,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/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs index 6f2bcb62f80..0ad24d0f9ea 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1696,11 +1696,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 @@ -2002,7 +2004,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 @@ -2038,7 +2040,7 @@ module TastDefinitionPrinting = |> addMaxMembers |> addLhs - | TFSharpUnionRepr _ -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } -> let denv = denv.AddAccessibility tycon.TypeReprAccessibility tycon.UnionCasesAsList |> layoutUnionCases denv infoReader tcref @@ -2048,7 +2050,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 [] @@ -2056,10 +2058,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 @@ -2072,7 +2074,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 @@ -2085,7 +2087,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 9338abd28f5..8ed798cd1d1 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2465,7 +2465,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) @@ -2503,7 +2503,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 8e10990d11d..cf8ee250af9 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -495,15 +495,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) @@ -513,23 +511,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 @@ -539,8 +547,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 20208e2870c..66f7483f523 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -1709,7 +1709,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 [] @@ -2165,28 +2165,30 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu 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 @@ -10522,9 +10524,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 @@ -10690,15 +10690,17 @@ 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 = @@ -10800,7 +10802,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 @@ -11004,7 +11006,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 = @@ -11049,7 +11051,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 @@ -11070,7 +11072,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 | _ -> () ] @@ -11093,15 +11096,14 @@ 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 + | TFSharpTyconRepr _ -> true | _ -> false) let ilAttrs = @@ -11251,7 +11253,7 @@ 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 -> diff --git a/src/Compiler/Service/SemanticClassification.fs b/src/Compiler/Service/SemanticClassification.fs index f1fdc92c0bb..3edfedc8074 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 06cf656b078..59fd54b9e94 100644 --- a/src/Compiler/Service/ServiceDeclarationLists.fs +++ b/src/Compiler/Service/ServiceDeclarationLists.fs @@ -856,15 +856,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 4b8f8c4684b..791c5bf30d7 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -576,7 +576,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 dfdc9640a0c..767258fd3a9 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -945,7 +945,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 @@ -981,12 +981,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 @@ -1057,9 +1060,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. @@ -1073,10 +1076,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 @@ -1097,7 +1107,7 @@ type Entity = 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 + member x.IsFSharpObjectModelTycon = match x.TypeReprInfo with | TFSharpTyconRepr _ -> 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. @@ -1112,16 +1122,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 @@ -1140,10 +1150,9 @@ type Entity = /// Indicates if this is an F#-defined struct or enum type definition, i.e. a value type definition 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 @@ -1409,13 +1418,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 @@ -1529,7 +1532,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 @@ -1545,18 +1554,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 @@ -1568,7 +1574,7 @@ type TyconObjModelData = [] member x.DebugText = x.ToString() - override x.ToString() = "TyconObjModelData(...)" + override x.ToString() = "FSharpTyconData(...)" /// Represents record fields in an F# type definition [] @@ -1631,6 +1637,7 @@ type TyconUnionCases = [] type TyconUnionData = { + /// The cases contained in the discriminated union. CasesTable: TyconUnionCases @@ -3604,7 +3611,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 @@ -5673,6 +5680,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 @@ -5801,7 +5814,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 b63942d2c8c..55f31ccd284 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -554,7 +554,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 @@ -871,13 +871,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 @@ -984,7 +978,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 @@ -1001,16 +1000,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 @@ -2411,7 +2409,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 @@ -4221,10 +4219,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: @@ -4261,6 +4258,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 f57954f7bf5..acfdf65a2b3 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -1896,9 +1896,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 @@ -4200,10 +4200,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 ...") @@ -4238,7 +4237,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) @@ -4520,7 +4518,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 @@ -4764,7 +4762,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 @@ -5111,10 +5109,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 @@ -6022,19 +6021,18 @@ and remapUnionCases ctxt tmenv (x: TyconUnionData) = and remapFsObjData ctxt tmenv x = { 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) - | TFSharpClass | TFSharpInterface | TFSharpStruct | TFSharpEnum -> x.fsobjmodel_kind) + | _ -> 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 90fd15fa1e2..c53928401be 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1879,34 +1879,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 dummy x = x -and p_tycon_repr x st = +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 @@ -2030,6 +2077,8 @@ and p_member_info (x: ValMemberInfo) st = and p_tycon_objmodel_kind x st = match x with + | TFSharpUnion -> failwith "unreachable, see p_tycon_repr" + | TFSharpRecord -> failwith "unreachable, see p_tycon_repr" | TFSharpClass -> p_byte 0 st | TFSharpInterface -> p_byte 1 st | TFSharpStruct -> p_byte 2 st @@ -2086,7 +2135,14 @@ and u_tycon_repr st = match tag2 with | 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 + }) | 1 -> let v = u_list u_unioncase_spec st (fun _flagBit -> Construct.MakeUnionRepr v) @@ -2117,16 +2173,25 @@ and u_tycon_repr st = 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" + | 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 = From c6cd691dd8ecbd67aa6b51a0e7a678b6f7eea7a0 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 18 Oct 2022 02:09:50 +0100 Subject: [PATCH 2/6] Ease restrictions on static members and static let in union and record types --- src/Compiler/Checking/CheckDeclarations.fs | 3 --- src/Compiler/Checking/CheckExpressions.fs | 4 ++-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index ec97a756d23..389d96e2236 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -923,9 +923,6 @@ 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 incrCtorInfoOpt then - // errorR(Error(FSComp.SR.tcStaticLetBindingsRequireClassesWithImplicitConstructors(), m)) - // Phase2A: let-bindings - pass through let innerState = (incrCtorInfoOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) [Phase2AIncrClassBindings (tcref, letBinds, isStatic, isRec, m)], innerState diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index f3b1e9ca645..67d1ecfc8eb 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -280,10 +280,10 @@ let noArgOrRetAttribs = ArgAndRetAttribs ([], []) 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 From 4c6386d2f1b5ec83c4620acad76026f8fdd1d371 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 19 Oct 2022 13:41:07 +0100 Subject: [PATCH 3/6] fix generation of .cctor for unions --- src/Compiler/AbstractIL/il.fs | 63 +++++++++++++++++---- src/Compiler/AbstractIL/il.fsi | 58 +++++++++++++++++++- src/Compiler/AbstractIL/ilwrite.fs | 4 ++ src/Compiler/AbstractIL/ilx.fs | 36 ++++++++++-- src/Compiler/Checking/CheckDeclarations.fs | 41 +++++++++----- src/Compiler/Checking/InfoReader.fs | 2 +- src/Compiler/CodeGen/IlxGen.fs | 64 +++++++++++----------- src/Compiler/TypedTree/TypedTree.fs | 30 +++++++--- src/Compiler/TypedTree/TypedTree.fsi | 18 +++--- src/Compiler/TypedTree/TypedTreePickle.fs | 15 ++++- 10 files changed, 250 insertions(+), 81 deletions(-) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index e0a5bb576aa..c477c6d2b98 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -193,20 +193,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. @@ -430,6 +432,7 @@ type AssemblyRefData = assemRefVersion: ILVersionInfo option assemRefLocale: Locale option } + override x.ToString() = x.assemRefName /// Global state: table of all assembly references keyed by AssemblyRefData. let AssemblyRefUniqueStampGenerator = UniqueStampGenerator() @@ -589,6 +592,8 @@ type ILModuleRef = member x.Hash = x.hash + override x.ToString() = x.Name + [] [] type ILScopeRef = @@ -678,6 +683,8 @@ 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() = @@ -997,7 +1004,7 @@ 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) = { @@ -1126,6 +1133,8 @@ type ILSourceDocument = member x.File = x.sourceFile + override x.ToString() = x.File + [] type ILDebugPoint = { @@ -1461,6 +1470,7 @@ type ILLocalDebugInfo = Range: ILCodeLabel * ILCodeLabel DebugMappings: ILLocalDebugMapping list } + override x.ToString() = (fst x.Range).ToString() + "-" + (snd x.Range).ToString() [] type ILCode = @@ -1470,6 +1480,7 @@ type ILCode = Exceptions: ILExceptionSpec list Locals: ILLocalDebugInfo list } + override x.ToString() = "" [] type ILLocal = @@ -1478,6 +1489,7 @@ type ILLocal = IsPinned: bool DebugInfo: (string * int * int) option } + override x.ToString() = "" type ILLocals = ILLocal list @@ -1494,6 +1506,7 @@ type ILDebugImports = Parent: ILDebugImports option Imports: ILDebugImport[] } + override x.ToString() = "" [] type ILMethodBody = @@ -1507,6 +1520,7 @@ type ILMethodBody = DebugRange: ILDebugPoint option DebugImports: ILDebugImports option } + override x.ToString() = "" [] type ILMemberAccess = @@ -1747,6 +1761,7 @@ type PInvokeMethod = ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar CharBestFit: PInvokeCharBestFit } + override x.ToString() = x.Name [] type ILParameter = @@ -1764,6 +1779,8 @@ type ILParameter = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = x.Name |> Option.defaultValue "" + type ILParameters = ILParameter list [] @@ -1775,6 +1792,8 @@ type ILReturn = MetadataIndex: int32 } + override x.ToString() = "" + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex member x.WithCustomAttrs(customAttrs) = @@ -1789,6 +1808,8 @@ 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 @@ -1811,7 +1832,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 = @@ -1996,7 +2017,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" @@ -2107,6 +2128,8 @@ type ILMethodDef member x.WithRuntime(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Runtime)) + override x.ToString() = x.Name + /// Index table by name and arity. type MethodDefMap = Map @@ -2152,7 +2175,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 @@ -2235,6 +2258,8 @@ type ILEventDefs = member x.LookupByName s = let (ILEvents t) = x in t[s] + override x.ToString() = "" + [] type ILPropertyDef ( @@ -2313,6 +2338,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 @@ -2414,6 +2441,8 @@ type ILFieldDef member x.WithFieldMarshal(marshal) = x.With(marshal = marshal, attributes = (x.Attributes |> conditionalAdd marshal.IsSome FieldAttributes.HasFieldMarshal)) + override x.ToString() = "field " + x.Name + // Index table by name. Keep a canonical list to make sure field order is not disturbed for binary manipulation. type ILFieldDefs = | ILFields of LazyOrderedMultiMap @@ -2422,6 +2451,8 @@ type ILFieldDefs = member x.LookupByName s = let (ILFields t) = x in t[s] + override x.ToString() = "" + type ILMethodImplDef = { Overrides: ILOverridesSpec @@ -2782,6 +2813,8 @@ type ILTypeDef member x.WithInitSemantics(init) = x.With(attributes = (x.Attributes ||| convertInitSemantics init)) + override x.ToString() = x.Name + and [] ILTypeDefs(f: unit -> ILPreTypeDef[]) = let mutable array = InlineDelayInit<_>(f) @@ -2797,10 +2830,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 @@ -2863,6 +2896,8 @@ type ILNestedExportedType = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "exported type " + x.Name + and ILNestedExportedTypes = | ILNestedExportedTypes of Lazy> @@ -2885,6 +2920,8 @@ and [] ILExportedTypeOrForwarder = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "exported type " + x.Name + and ILExportedTypesAndForwarders = | ILExportedTypesAndForwarders of Lazy> @@ -2923,6 +2960,8 @@ type ILResource = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "resource " + x.Name + type ILResources = | ILResources of ILResource list @@ -2970,6 +3009,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 @@ -3013,6 +3054,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 3ea66ef5bf2..acef6bfd83a 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,19 +1145,33 @@ 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 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 @@ -1149,10 +1179,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. @@ -1185,20 +1220,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 @@ -1212,12 +1259,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 80bb791c25f..847ebf2bb08 100644 --- a/src/Compiler/AbstractIL/ilwrite.fs +++ b/src/Compiler/AbstractIL/ilwrite.fs @@ -407,6 +407,8 @@ type MetadataTable<'T> = member tbl.GetTableEntry x = tbl.dict[x] + override x.ToString() = "table " + x.name + //--------------------------------------------------------------------- // Keys into some of the tables //--------------------------------------------------------------------- @@ -453,6 +455,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 e91ad50d712..971d5bf3dd8 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 @@ -99,6 +118,8 @@ type IlxClosureFreeVar = fvType: ILType } + override x.ToString() = x.fvName + let mkILFreeVar (name, compgen, ty) = { fvName = name @@ -106,7 +127,8 @@ let mkILFreeVar (name, compgen, ty) = fvType = ty } -type IlxClosureRef = IlxClosureRef of ILTypeRef * IlxClosureLambdas * IlxClosureFreeVar[] +type IlxClosureRef = + | IlxClosureRef of ILTypeRef * IlxClosureLambdas * IlxClosureFreeVar[] type IlxClosureSpec = | IlxClosureSpec of IlxClosureRef * ILGenericArgs * ILType * useStaticField: bool @@ -141,6 +163,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 = { @@ -171,12 +195,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 389d96e2236..ee81eb41171 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -1203,7 +1203,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). @@ -3320,7 +3320,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 = TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpRecord) + 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, _) -> @@ -3451,13 +3459,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 = - TFSharpTyconRepr - { fsobjmodel_cases = Construct.MakeUnionCases [] - 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) -> @@ -3475,12 +3484,14 @@ module EstablishTypeDefinitionCores = errorR(Error(FSComp.SR.tcInvalidTypeForLiteralEnumeration(), m)) writeFakeRecordFieldsToSink fields' - let repr = - TFSharpTyconRepr - { fsobjmodel_cases = Construct.MakeUnionCases [] - 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 diff --git a/src/Compiler/Checking/InfoReader.fs b/src/Compiler/Checking/InfoReader.fs index 27eb5c2547e..24db327dc7e 100644 --- a/src/Compiler/Checking/InfoReader.fs +++ b/src/Compiler/Checking/InfoReader.fs @@ -487,7 +487,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/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 66f7483f523..5d0eca2fc38 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -1902,29 +1902,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 @@ -11082,6 +11082,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 @@ -11102,9 +11119,9 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = // Build a basic type definition let isObjectType = - (match tyconRepr with - | TFSharpTyconRepr _ -> true - | _ -> false) + match k with + | TFSharpRecord _ -> false + | _ -> true let ilAttrs = ilCustomAttrs @@ -11121,23 +11138,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 @@ -11338,7 +11338,9 @@ 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/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 767258fd3a9..ae19e714839 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -1106,8 +1106,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 | TFSharpTyconRepr _ -> 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. @@ -1146,8 +1159,7 @@ 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 | TFSharpTyconRepr info -> @@ -1162,7 +1174,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 @@ -3627,7 +3639,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 @@ -3669,7 +3681,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 @@ -3709,7 +3723,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 diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 55f31ccd284..951bee082fc 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -612,10 +612,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, @@ -625,7 +627,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. @@ -674,7 +676,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. @@ -2464,10 +2466,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, @@ -2527,7 +2531,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 diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index c53928401be..37f3cfb6075 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -2077,13 +2077,13 @@ and p_member_info (x: ValMemberInfo) st = and p_tycon_objmodel_kind x st = match x with - | TFSharpUnion -> failwith "unreachable, see p_tycon_repr" - | TFSharpRecord -> failwith "unreachable, see p_tycon_repr" | TFSharpClass -> p_byte 0 st | TFSharpInterface -> p_byte 1 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 @@ -2133,6 +2133,7 @@ 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 -> @@ -2143,9 +2144,12 @@ and u_tycon_repr st = 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 @@ -2171,13 +2175,18 @@ and u_tycon_repr st = TNoRepr else TAsmRepr v) + | 3 -> let v = u_tycon_objmodel_data st (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 @@ -2385,6 +2394,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 = From 509f16d6987eda7696b05662736e34a0303a95b3 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 19 Oct 2022 14:45:53 +0100 Subject: [PATCH 4/6] fix build --- .../Checking/CheckIncrementalClasses.fs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Checking/CheckIncrementalClasses.fs b/src/Compiler/Checking/CheckIncrementalClasses.fs index 1befa8ec6ba..3e3e2fe1cd6 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fs +++ b/src/Compiler/Checking/CheckIncrementalClasses.fs @@ -489,11 +489,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 <- TFSharpTyconRepr { tcref.FSharpTyconRepresentationData 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. From 3ba36c3a287052745a958eeb5e4d51a0d092308f Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 19 Oct 2022 15:09:53 +0100 Subject: [PATCH 5/6] fix formatting --- src/Compiler/AbstractIL/il.fs | 22 +++++++++++---- src/Compiler/AbstractIL/ilx.fs | 3 +- .../Checking/CheckIncrementalClasses.fsi | 7 +---- src/Compiler/CodeGen/IlxGen.fs | 28 +++++++++++++++---- 4 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index c477c6d2b98..e3d0cd28f20 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -432,6 +432,7 @@ type AssemblyRefData = assemRefVersion: ILVersionInfo option assemRefLocale: Locale option } + override x.ToString() = x.assemRefName /// Global state: table of all assembly references keyed by AssemblyRefData. @@ -683,7 +684,8 @@ type ILCallingConv = static member Static = ILCallingConvStatics.Static - override x.ToString() = if x.IsStatic then "static" else "instance" + override x.ToString() = + if x.IsStatic then "static" else "instance" /// Static storage to amortize the allocation of ILCallingConv.Instance and ILCallingConv.Static. and ILCallingConvStatics() = @@ -1004,7 +1006,8 @@ type ILMethodRef = member x.ReturnType = x.mrefReturn - member x.GetCallingSignature() = 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) = { @@ -1470,7 +1473,9 @@ type ILLocalDebugInfo = Range: ILCodeLabel * ILCodeLabel DebugMappings: ILLocalDebugMapping list } - override x.ToString() = (fst x.Range).ToString() + "-" + (snd x.Range).ToString() + + override x.ToString() = + (fst x.Range).ToString() + "-" + (snd x.Range).ToString() [] type ILCode = @@ -1480,6 +1485,7 @@ type ILCode = Exceptions: ILExceptionSpec list Locals: ILLocalDebugInfo list } + override x.ToString() = "" [] @@ -1489,6 +1495,7 @@ type ILLocal = IsPinned: bool DebugInfo: (string * int * int) option } + override x.ToString() = "" type ILLocals = ILLocal list @@ -1506,6 +1513,7 @@ type ILDebugImports = Parent: ILDebugImports option Imports: ILDebugImport[] } + override x.ToString() = "" [] @@ -1520,6 +1528,7 @@ type ILMethodBody = DebugRange: ILDebugPoint option DebugImports: ILDebugImports option } + override x.ToString() = "" [] @@ -1761,6 +1770,7 @@ type PInvokeMethod = ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar CharBestFit: PInvokeCharBestFit } + override x.ToString() = x.Name [] @@ -1779,7 +1789,8 @@ type ILParameter = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex - override x.ToString() = x.Name |> Option.defaultValue "" + override x.ToString() = + x.Name |> Option.defaultValue "" type ILParameters = ILParameter list @@ -1808,7 +1819,8 @@ type ILOverridesSpec = member x.DeclaringType = let (OverridesSpec (_mr, ty)) = x in ty - override x.ToString() = "overrides " + x.DeclaringType.ToString() + "::" + x.MethodRef.ToString() + override x.ToString() = + "overrides " + x.DeclaringType.ToString() + "::" + x.MethodRef.ToString() type ILMethodVirtualInfo = { diff --git a/src/Compiler/AbstractIL/ilx.fs b/src/Compiler/AbstractIL/ilx.fs index 971d5bf3dd8..8b167ce778e 100644 --- a/src/Compiler/AbstractIL/ilx.fs +++ b/src/Compiler/AbstractIL/ilx.fs @@ -127,8 +127,7 @@ let mkILFreeVar (name, compgen, ty) = fvType = ty } -type IlxClosureRef = - | IlxClosureRef of ILTypeRef * IlxClosureLambdas * IlxClosureFreeVar[] +type IlxClosureRef = IlxClosureRef of ILTypeRef * IlxClosureLambdas * IlxClosureFreeVar[] type IlxClosureSpec = | IlxClosureSpec of IlxClosureRef * ILGenericArgs * ILType * useStaticField: bool diff --git a/src/Compiler/Checking/CheckIncrementalClasses.fsi b/src/Compiler/Checking/CheckIncrementalClasses.fsi index 2ed5c559d80..0de56111ff9 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fsi +++ b/src/Compiler/Checking/CheckIncrementalClasses.fsi @@ -119,12 +119,7 @@ type IncrClassConstructionBindingsPhase2C = /// Check and elaborate the "left hand side" of the implicit class construction /// syntax. val TcStaticImplicitCtorInfo_Phase2A: - cenv: TcFileState * - env: TcEnv * - tcref: TyconRef * - m: range * - copyOfTyconTypars: Typar list -> - StaticCtorInfo + 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. diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 5d0eca2fc38..60546a54cd7 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2165,6 +2165,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu if isStruct then tycon.SetIsStructRecordOrUnion true + let rfields = (tps, flds) ||> List.map2 (fun tp (propName, _fldName, _fldTy) -> @@ -2181,6 +2182,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu XmlDoc.Empty taccessPublic false) + let data = { fsobjmodel_cases = Construct.MakeUnionCases [] @@ -2188,6 +2190,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu fsobjmodel_kind = TFSharpRecord fsobjmodel_vslots = [] } + tycon.entity_tycon_repr <- TFSharpTyconRepr data let tcref = mkLocalTyconRef tycon let ty = generalizedTyconRef g tcref @@ -10694,8 +10697,10 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = match o.fsobjmodel_kind with | TFSharpUnion | TFSharpRecord -> - if tycon.IsStructOrEnumTycon then ILTypeDefKind.ValueType - else ILTypeDefKind.Class + if tycon.IsStructOrEnumTycon then + ILTypeDefKind.ValueType + else + ILTypeDefKind.Class | TFSharpClass -> ILTypeDefKind.Class | TFSharpStruct -> ILTypeDefKind.ValueType | TFSharpInterface -> ILTypeDefKind.Interface @@ -11113,7 +11118,11 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = tdef, None - | TFSharpTyconRepr { fsobjmodel_kind = k } when (match k with TFSharpUnion -> false | _ -> true) -> + | TFSharpTyconRepr { fsobjmodel_kind = k } when + (match k with + | TFSharpUnion -> false + | _ -> true) + -> let super = superOfTycon g tycon let ilBaseTy = GenType cenv m eenvinner.tyenv super @@ -11253,7 +11262,11 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = tdef, None - | TFSharpTyconRepr { fsobjmodel_kind = k } when (match k with TFSharpUnion -> true | _ -> false) -> + | TFSharpTyconRepr { fsobjmodel_kind = k } when + (match k with + | TFSharpUnion -> true + | _ -> false) + -> let alternatives = tycon.UnionCasesArray |> Array.mapi (fun i ucspec -> @@ -11340,7 +11353,12 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = .WithAccess(access) // 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) + .WithInitSemantics( + if ilFields.AsList().IsEmpty then + ILTypeInit.BeforeField + else + typeDefTrigger + ) let tdef2 = EraseUnions.mkClassUnionDef From 4f0a31013b00fde9080095ccdc19f9bd74990730 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 8 Jun 2023 10:18:30 +0000 Subject: [PATCH 6/6] Automated command ran: fantomas Co-authored-by: T-Gro <46543583+T-Gro@users.noreply.github.com> --- src/Compiler/AbstractIL/il.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 3e819b6429a..b438cc1d79d 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -2448,7 +2448,6 @@ type ILFieldDef member x.WithFieldMarshal(marshal) = x.With(marshal = marshal, attributes = (x.Attributes |> conditionalAdd marshal.IsSome FieldAttributes.HasFieldMarshal)) - [] member x.DebugText = x.ToString()