From 56f6c57e19f5576ef477bed05febb474bfabf6dc Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 2 Mar 2023 16:08:20 +0100 Subject: [PATCH 01/14] Fix typar pretty naming for graph type-checking. --- src/Compiler/Checking/CheckDeclarations.fs | 3 ++- src/Compiler/Checking/CheckDeclarations.fsi | 1 + src/Compiler/Checking/PostInferenceChecks.fs | 26 ++++++++++++++---- src/Compiler/Checking/PostInferenceChecks.fsi | 1 + src/Compiler/Driver/ParseAndCheckInputs.fs | 27 ++++++++++++++++--- src/Compiler/TypedTree/TypedTree.fs | 10 +++++-- src/Compiler/TypedTree/TypedTree.fsi | 4 +++ src/Compiler/TypedTree/TypedTreeBasics.fs | 3 ++- src/Compiler/TypedTree/TypedTreePickle.fs | 3 ++- .../TypeChecks/Graph/CompilationTests.fs | 2 +- 10 files changed, 65 insertions(+), 15 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 85a72fa3222..c5f28bb6b31 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5367,6 +5367,7 @@ let CheckOneImplFile env, rootSigOpt: ModuleOrNamespaceType option, synImplFile, + fileIdx, diagnosticOptions) = let (ParsedImplFileInput (fileName, isScript, qualNameOfFile, scopedPragmas, _, implFileFrags, isLastCompiland, _, _)) = synImplFile @@ -5470,7 +5471,7 @@ let CheckOneImplFile PostTypeCheckSemanticChecks.CheckImplFile (g, cenv.amap, reportErrors, cenv.infoReader, env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, - implFileTy, implFileContents, extraAttribs, isLastCompiland, + implFileTy, implFileContents, extraAttribs, fileIdx, isLastCompiland, isInternalTestSpanStackReferring) with exn -> diff --git a/src/Compiler/Checking/CheckDeclarations.fsi b/src/Compiler/Checking/CheckDeclarations.fsi index fb4679f2438..09a88163ff8 100644 --- a/src/Compiler/Checking/CheckDeclarations.fsi +++ b/src/Compiler/Checking/CheckDeclarations.fsi @@ -60,6 +60,7 @@ val CheckOneImplFile: TcEnv * ModuleOrNamespaceType option * ParsedImplFileInput * + FileIndex option * FSharpDiagnosticOptions -> Cancellable diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index bb833eebabd..305bba88e25 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -102,6 +102,11 @@ type env = /// Are we expecting a resumable code block etc resumableCode: Resumable + + /// Do we know the current file index? + /// If we do this means we are processing type-checking files using the parallel graph mode, + /// and should account for naming the typars according to the lowest file index. + fileIndex: int option } override _.ToString() = "" @@ -116,9 +121,19 @@ let BindTypars g env (tps: Typar list) = if isNil tps then env else // Here we mutate to provide better names for generalized type parameters let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps - (tps, nms) ||> List.iter2 (fun tp nm -> - if PrettyTypes.NeedsPrettyTyparName tp then - tp.typar_id <- ident (nm, tp.Range)) + (tps, nms) + ||> List.iter2 (fun tp nm -> + if PrettyTypes.NeedsPrettyTyparName tp then + let typar_id = ident (nm, tp.Range) + match env.fileIndex with + | None -> + tp.typar_id <- typar_id + | Some idx -> + if tp.id_suggestions.ContainsKey idx then + tp.id_suggestions.[idx] <- typar_id + else + tp.id_suggestions.Add(idx, typar_id) + ) List.fold BindTypar env tps /// Set the set of vals which are arguments in the active lambda. We are allowed to return @@ -2599,7 +2614,7 @@ let CheckImplFileContents cenv env implFileTy implFileContents = let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } CheckDefnInModule cenv env implFileContents -let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = +let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, fileIndex, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = let cenv = { g = g reportErrors = reportErrors @@ -2640,7 +2655,8 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v external=false returnScope = 0 isInAppExpr = false - resumableCode = Resumable.None } + resumableCode = Resumable.None + fileIndex = fileIndex } CheckImplFileContents cenv env implFileTy implFileContents CheckAttribs cenv env extraAttribs diff --git a/src/Compiler/Checking/PostInferenceChecks.fsi b/src/Compiler/Checking/PostInferenceChecks.fsi index 6e289af71c8..14b537ec483 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fsi +++ b/src/Compiler/Checking/PostInferenceChecks.fsi @@ -23,6 +23,7 @@ val CheckImplFile: implFileTy: ModuleOrNamespaceType * implFileContents: ModuleOrNamespaceContents * extraAttribs: Attribs * + fileIndex: int option * (bool * bool) * isInternalTestSpanStackReferring: bool -> bool * StampMap diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 309b858e4d2..6589dfba591 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1321,6 +1321,7 @@ let CheckOneInputAux tcState.tcsTcImplEnv, rootSigOpt, file, + None, tcConfig.diagnosticsOptions ) @@ -1469,7 +1470,7 @@ let CheckOneInputWithCallback tcSink, tcState: TcState, inp: ParsedInput, - _skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool) + idx: FileIndex): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * FileIndex) : Cancellable> = cancellable { try @@ -1559,6 +1560,7 @@ let CheckOneInputWithCallback tcState.tcsTcImplEnv, rootSigOpt, file, + Some idx, tcConfig.diagnosticsOptions ) @@ -1610,6 +1612,19 @@ let AddSignatureResultToTcImplEnv (tcImports: TcImports, tcGlobals, prefixPathOp partialResult, tcState +let rec kindaEvilFixingEntity (entity: Entity) = + for e in entity.ModuleOrNamespaceType.AllEntities do + kindaEvilFixingEntity e + + for v in entity.ModuleOrNamespaceType.AllValsAndMembers do + kindaEvilFixingTypars v + +and kindaEvilFixingTypars (v: Val) = + for typar in v.Typars do + if typar.id_suggestions.Count > 0 then + let lowestKey = typar.id_suggestions.Keys |> Seq.min + typar.typar_id <- typar.id_suggestions.[lowestKey] + /// Constructs a file dependency graph and type-checks the files in parallel where possible. let CheckMultipleInputsUsingGraphMode ((ctok, checkForErrors, tcConfig: TcConfig, tcImports: TcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs): 'a * (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcState * (PhasedDiagnostic -> PhasedDiagnostic) * ParsedInput list) @@ -1706,6 +1721,7 @@ let CheckMultipleInputsUsingGraphMode partialResult, (nextTcState, currentPriorErrors)) let processFile + (idx: FileIndex) ((input, logger): ParsedInput * DiagnosticsLogger) ((currentTcState, _currentPriorErrors): State) : Finisher = @@ -1714,7 +1730,7 @@ let CheckMultipleInputsUsingGraphMode let tcSink = TcResultsSink.NoSink let finisher = - CheckOneInputWithCallback(checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, false) + CheckOneInputWithCallback(checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, idx) |> Cancellable.runWithoutCancellation Finisher(fun (state: State) -> @@ -1741,7 +1757,7 @@ let CheckMultipleInputsUsingGraphMode processArtificialImplFile parsedInput state | NodeToTypeCheck.PhysicalFile idx -> let parsedInput, logger = inputsWithLoggers[idx] - processFile (parsedInput, logger) state + processFile idx (parsedInput, logger) state let state: State = tcState, priorErrors @@ -1765,13 +1781,16 @@ let CheckMultipleInputsUsingGraphMode |> List.sortBy fst |> List.map snd + // Yup, that evil + kindaEvilFixingEntity tcState.Ccu.Deref.Contents + partialResults, tcState) let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs) = // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions let results, tcState = match tcConfig.typeCheckingConfig.Mode with - | TypeCheckingMode.Graph when (not tcConfig.isInteractive && not tcConfig.deterministic) -> + | TypeCheckingMode.Graph when (not tcConfig.isInteractive) -> CheckMultipleInputsUsingGraphMode( ctok, checkForErrors, diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index af37bf45c92..ace0279cba9 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2139,6 +2139,10 @@ type Typar = /// The optional data for the type parameter mutable typar_opt_data: TyparOptionalData option + + /// When type-checking using the graph method, multiple proposals for the typar_id can be found concurrently. + /// We would pick the ident with the lowest file index value (int), as that is the name the sequential type-checking would pick. + id_suggestions: Dictionary } /// The name of the type parameter @@ -2248,7 +2252,8 @@ type Typar = typar_stamp = -1L typar_solution = Unchecked.defaultof<_> typar_astype = Unchecked.defaultof<_> - typar_opt_data = Unchecked.defaultof<_> } + typar_opt_data = Unchecked.defaultof<_> + id_suggestions = Dictionary(1) } /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. static member New (data: TyparData) : Typar = data @@ -5835,7 +5840,8 @@ type Construct() = typar_opt_data = match attribs with | [] -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } } + | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } + id_suggestions = Dictionary(0) } /// Create a new type parameter node for a declared type parameter static member NewRigidTypar nm m = diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 8cee5e349f7..225d074b54d 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -1466,6 +1466,10 @@ type Typar = /// The optional data for the type parameter mutable typar_opt_data: TyparOptionalData option + + /// When type-checking using the graph method, multiple proposals for the typar_id can be found concurrently. + /// We would pick the ident with the lowest file index value (int), as that is the name the sequential type-checking would pick. + id_suggestions: Dictionary } /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index 511a4cc44f2..c9c9529ffc8 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -205,7 +205,8 @@ let copyTypar clearStaticReq (tp: Typar) = typar_solution = tp.typar_solution typar_astype = Unchecked.defaultof<_> // Be careful to clone the mutable optional data too - typar_opt_data = optData } + typar_opt_data = optData + id_suggestions = tp.id_suggestions } let copyTypars clearStaticReq tps = List.map (copyTypar clearStaticReq) tps diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 818d36ecc9c..ebfa690c6e5 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1615,7 +1615,8 @@ let u_tyar_spec_data st = typar_opt_data= match g, e, c with | doc, [], [] when doc.IsEmpty -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c } } + | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c } + id_suggestions = Dictionary(0) } let u_tyar_spec st = u_osgn_decl st.itypars u_tyar_spec_data st diff --git a/tests/FSharp.Compiler.ComponentTests/TypeChecks/Graph/CompilationTests.fs b/tests/FSharp.Compiler.ComponentTests/TypeChecks/Graph/CompilationTests.fs index c1df009ffff..dc5f30df911 100644 --- a/tests/FSharp.Compiler.ComponentTests/TypeChecks/Graph/CompilationTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/TypeChecks/Graph/CompilationTests.fs @@ -13,7 +13,7 @@ type Method = let methodOptions (method: Method) = match method with | Method.Sequential -> [] - | Method.Graph -> [ "--test:GraphBasedChecking"; "--test:DumpCheckingGraph"; "--deterministic-" ] + | Method.Graph -> [ "--test:GraphBasedChecking"; "--test:DumpCheckingGraph" ] let withMethod (method: Method) (cu: CompilationUnit) : CompilationUnit = match cu with From f8de8c8f65b758d053cccf60d43cb37ae854cedf Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 2 Mar 2023 19:02:05 +0100 Subject: [PATCH 02/14] Do evil hack a little later. --- src/Compiler/Driver/ParseAndCheckInputs.fs | 16 ---------------- src/Compiler/Driver/fsc.fs | 16 ++++++++++++++++ 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 6589dfba591..396a8d902e1 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1612,19 +1612,6 @@ let AddSignatureResultToTcImplEnv (tcImports: TcImports, tcGlobals, prefixPathOp partialResult, tcState -let rec kindaEvilFixingEntity (entity: Entity) = - for e in entity.ModuleOrNamespaceType.AllEntities do - kindaEvilFixingEntity e - - for v in entity.ModuleOrNamespaceType.AllValsAndMembers do - kindaEvilFixingTypars v - -and kindaEvilFixingTypars (v: Val) = - for typar in v.Typars do - if typar.id_suggestions.Count > 0 then - let lowestKey = typar.id_suggestions.Keys |> Seq.min - typar.typar_id <- typar.id_suggestions.[lowestKey] - /// Constructs a file dependency graph and type-checks the files in parallel where possible. let CheckMultipleInputsUsingGraphMode ((ctok, checkForErrors, tcConfig: TcConfig, tcImports: TcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs): 'a * (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcState * (PhasedDiagnostic -> PhasedDiagnostic) * ParsedInput list) @@ -1781,9 +1768,6 @@ let CheckMultipleInputsUsingGraphMode |> List.sortBy fst |> List.map snd - // Yup, that evil - kindaEvilFixingEntity tcState.Ccu.Deref.Contents - partialResults, tcState) let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs) = diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index d59676d082e..9e576834156 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -689,6 +689,22 @@ let main1 AbortOnError(diagnosticsLogger, exiter) ReportTime tcConfig "Typechecked" + // Fixup typars + let rec kindaEvilFixingEntity (entity: Entity) = + for e in entity.ModuleOrNamespaceType.AllEntities do + kindaEvilFixingEntity e + + for v in entity.ModuleOrNamespaceType.AllValsAndMembers do + kindaEvilFixingTypars v + + and kindaEvilFixingTypars (v: Val) = + for typar in v.Typars do + if typar.id_suggestions.Count > 0 then + let lowestKey = typar.id_suggestions.Keys |> Seq.min + typar.typar_id <- typar.id_suggestions.[lowestKey] + + kindaEvilFixingEntity tcState.Ccu.Deref.Contents + Args( ctok, tcGlobals, From 6265fabdfae2af98f6239f5e75204dd6b80ab82a Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 15 Mar 2023 14:32:33 +0100 Subject: [PATCH 03/14] Convert Typar to class, lock typar_id in SetIdent assignment. --- src/Compiler/Checking/CheckExpressions.fs | 2 +- src/Compiler/Checking/ConstraintSolver.fs | 10 +- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 11 +- src/Compiler/Checking/SignatureConformance.fs | 2 +- src/Compiler/Driver/fsc.fs | 16 -- src/Compiler/Optimize/Optimizer.fs | 9 +- src/Compiler/TypedTree/TypedTree.fs | 221 ++++++++++-------- src/Compiler/TypedTree/TypedTree.fsi | 68 +++--- src/Compiler/TypedTree/TypedTreeBasics.fs | 27 +-- src/Compiler/TypedTree/TypedTreeOps.fs | 18 +- src/Compiler/TypedTree/TypedTreeOps.fsi | 2 +- src/Compiler/TypedTree/TypedTreePickle.fs | 16 +- 13 files changed, 216 insertions(+), 188 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index c7dee26d748..797524e1aae 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -11967,7 +11967,7 @@ and FixupLetrecBind (cenv: cenv) denv generalizedTyparsForRecursiveBlock (bind: // TcLetrecBindings - for both expressions and class-let-rec-declarations //------------------------------------------------------------------------ -and unionGeneralizedTypars typarSets = List.foldBack (ListSet.unionFavourRight typarEq) typarSets [] +and unionGeneralizedTypars (typarSets: Typars list) = List.foldBack (ListSet.unionFavourRight typarEq) typarSets [] and TcLetrecBindings overridesOK (cenv: cenv) env tpenv (binds, bindsm, scopem) = diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 6b0ef85d5e8..0e1bde44aca 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -693,8 +693,8 @@ let SubstMeasure (r: Typar) ms = if r.Rigidity = TyparRigidity.Rigid then error(InternalError("SubstMeasure: rigid", r.Range)) if r.Kind = TyparKind.Type then error(InternalError("SubstMeasure: kind=type", r.Range)) - match r.typar_solution with - | None -> r.typar_solution <- Some (TType_measure ms) + match r.Solution with + | None -> r.SetSolution(TType_measure ms) | Some _ -> error(InternalError("already solved", r.Range)) let rec TransactStaticReq (csenv: ConstraintSolverEnv) (trace: OptionalTrace) (tpr: Typar) req = @@ -993,7 +993,7 @@ let rec SolveTyparEqualsTypePart1 (csenv: ConstraintSolverEnv) m2 (trace: Option // Record the solution before we solve the constraints, since // We may need to make use of the equation when solving the constraints. // Record a entry in the undo trace if one is provided - trace.Exec (fun () -> r.typar_solution <- Some ty) (fun () -> r.typar_solution <- None) + trace.Exec (fun () -> r.SetSolution(ty)) (fun () -> r.ClearSolution()) } and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (r: Typar) ty = trackErrors { @@ -3695,7 +3695,7 @@ let ChooseTyparSolutionAndSolve css denv tp = (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult -let CheckDeclaredTypars denv css m typars1 typars2 = +let CheckDeclaredTypars denv css m (typars1: Typars) (typars2: Typars) = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> @@ -3707,7 +3707,7 @@ let CheckDeclaredTypars denv css m typars1 typars2 = ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let CanonicalizePartialInferenceProblem css denv m tps = +let CanonicalizePartialInferenceProblem css denv m (tps: Typars) = // Canonicalize constraints prior to generalization let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 414d102b691..b2212a7c86d 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -3905,7 +3905,7 @@ let ResolveExprDotLongIdentAndComputeRange (sink: TcResultsSink) (ncenv: NameRes //------------------------------------------------------------------------- /// A generator of type instantiations used when no more specific type instantiation is known. -let FakeInstantiationGenerator (_m: range) gps = List.map mkTyparTy gps +let FakeInstantiationGenerator (_m: range) (gps: Typars) = List.map mkTyparTy gps // note: using local refs is ok since it is only used by VS let ItemForModuleOrNamespaceRef v = Item.ModuleOrNamespaces [v] diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 305bba88e25..a4d69f8964c 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -116,23 +116,20 @@ let BindTypar env (tp: Typar) = boundTyparNames = tp.Name :: env.boundTyparNames boundTypars = env.boundTypars.Add (tp, ()) } -let BindTypars g env (tps: Typar list) = +let BindTypars g env (tps: Typars) = let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps if isNil tps then env else // Here we mutate to provide better names for generalized type parameters let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps (tps, nms) ||> List.iter2 (fun tp nm -> + let typar_id = ident (nm, tp.Range) if PrettyTypes.NeedsPrettyTyparName tp then - let typar_id = ident (nm, tp.Range) match env.fileIndex with | None -> - tp.typar_id <- typar_id + tp.SetIdent(TyparId.Initial(typar_id)) | Some idx -> - if tp.id_suggestions.ContainsKey idx then - tp.id_suggestions.[idx] <- typar_id - else - tp.id_suggestions.Add(idx, typar_id) + tp.SetIdent(TyparId.PrettyTyparName(typar_id, idx, typar_id)) ) List.fold BindTypar env tps diff --git a/src/Compiler/Checking/SignatureConformance.fs b/src/Compiler/Checking/SignatureConformance.fs index cf2d2a0bc13..cf610c32724 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -133,7 +133,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m)) // Adjust the actual type parameter name to look like the signature - implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText) + implTypar.SetIdent (TyparId.Initial(mkSynId implTypar.Range sigTypar.Id.idText)) // Mark it as "not compiler generated", now that we've got a good name for it implTypar.SetCompilerGenerated false diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 9e576834156..d59676d082e 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -689,22 +689,6 @@ let main1 AbortOnError(diagnosticsLogger, exiter) ReportTime tcConfig "Typechecked" - // Fixup typars - let rec kindaEvilFixingEntity (entity: Entity) = - for e in entity.ModuleOrNamespaceType.AllEntities do - kindaEvilFixingEntity e - - for v in entity.ModuleOrNamespaceType.AllValsAndMembers do - kindaEvilFixingTypars v - - and kindaEvilFixingTypars (v: Val) = - for typar in v.Typars do - if typar.id_suggestions.Count > 0 then - let lowestKey = typar.id_suggestions.Keys |> Seq.min - typar.typar_id <- typar.id_suggestions.[lowestKey] - - kindaEvilFixingEntity tcState.Ccu.Deref.Contents - Args( ctok, tcGlobals, diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 343d911aa4d..517a6fb2baf 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -604,9 +604,12 @@ let BindTyparsToUnknown (tps: Typar list) env = // However here we mutate to provide better names for generalized type parameters // The names chosen are 'a', 'b' etc. These are also the compiled names in the IL code let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) (env.typarInfos |> List.map (fun (tp, _) -> tp.Name) ) tps - (tps, nms) ||> List.iter2 (fun tp nm -> - if PrettyTypes.NeedsPrettyTyparName tp then - tp.typar_id <- ident (nm, tp.Range)) + (tps, nms) + ||> List.iter2 (fun tp nm -> + if PrettyTypes.NeedsPrettyTyparName tp then + // As the optimize phase is not happening in parallel, we can safely write the ident. + tp.SetIdent(TyparId.Initial(ident (nm, tp.Range))) + ) List.fold (fun sofar arg -> BindTypar arg UnknownTypeValue sofar) env tps let BindCcu (ccu: CcuThunk) mval env (_g: TcGlobals) = diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index ace0279cba9..7be1a861673 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2116,172 +2116,189 @@ type TyparOptionalData = type TyparData = Typar -/// A declared generic type/measure parameter, or a type/measure inference variable. +[] +type TyparId = + | Initial of Ident + | PrettyTyparName of originalIdent: Ident * currentIndex: int * currentIdent: Ident + +/// A declared generic type/measure parameter, or a type/measure inference variable. +/// +/// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation. +/// The identifier for the type parameter. +/// +/// The flag data for the type parameter. +/// +/// The unique stamp of the type parameter +/// MUTABILITY: for linking when unpickling +/// +/// An inferred equivalence for a type inference variable. +/// A cached TAST type used when this type variable is used as type. +/// The optional data for the type parameter. [] -type Typar = - { - /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation - /// The identifier for the type parameter - mutable typar_id: Ident - - /// The flag data for the type parameter - mutable typar_flags: TyparFlags - - /// The unique stamp of the type parameter - /// MUTABILITY: for linking when unpickling - mutable typar_stamp: Stamp - - /// An inferred equivalence for a type inference variable. - mutable typar_solution: TType option - - /// A cached TAST type used when this type variable is used as type. - mutable typar_astype: TType - - /// The optional data for the type parameter - mutable typar_opt_data: TyparOptionalData option - - /// When type-checking using the graph method, multiple proposals for the typar_id can be found concurrently. - /// We would pick the ident with the lowest file index value (int), as that is the name the sequential type-checking would pick. - id_suggestions: Dictionary - } +type Typar + ( + typar_id: TyparId, + typar_flags: TyparFlags, + typar_stamp: Stamp, + typar_solution: TType option, + typar_astype: TType, + typar_opt_data: TyparOptionalData option + ) = + let mutable typar_id: TyparId = typar_id + let mutable typar_flags: TyparFlags = typar_flags + let mutable typar_stamp: Stamp = typar_stamp + let mutable typar_solution: TType option = typar_solution + let mutable typar_astype: TType = typar_astype + let mutable typar_opt_data: TyparOptionalData option = typar_opt_data + let lockObj = obj() /// The name of the type parameter - member x.Name = x.typar_id.idText + member x.Name = x.Id.idText /// The range of the identifier for the type parameter definition - member x.Range = x.typar_id.idRange + member x.Range = x.Id.idRange /// The identifier for a type parameter definition - member x.Id = x.typar_id + member x.Id : Ident = + match typar_id with + | Initial(ident) + | PrettyTyparName(currentIdent = ident) -> ident + + member x.TyparId = typar_id + + member x.Flags = typar_flags + + member x.OptionalData = typar_opt_data /// The unique stamp of the type parameter - member x.Stamp = x.typar_stamp + member x.Stamp = typar_stamp /// The inferred equivalence for the type inference variable, if any. - member x.Solution = x.typar_solution + member x.Solution = typar_solution /// The inferred constraints for the type inference variable, if any member x.Constraints = - match x.typar_opt_data with + match typar_opt_data with | Some optData -> optData.typar_constraints | _ -> [] /// Indicates if the type variable is compiler generated, i.e. is an implicit type inference variable - member x.IsCompilerGenerated = x.typar_flags.IsCompilerGenerated + member x.IsCompilerGenerated = typar_flags.IsCompilerGenerated /// Indicates if the type variable can be solved or given new constraints. The status of a type variable /// generally always evolves towards being either rigid or solved. - member x.Rigidity = x.typar_flags.Rigidity + member x.Rigidity = typar_flags.Rigidity /// Indicates if a type parameter is needed at runtime and may not be eliminated - member x.DynamicReq = x.typar_flags.DynamicReq + member x.DynamicReq = typar_flags.DynamicReq /// Indicates that whether or not a generic type definition satisfies the equality constraint is dependent on whether this type variable satisfies the equality constraint. - member x.EqualityConditionalOn = x.typar_flags.EqualityConditionalOn + member x.EqualityConditionalOn = typar_flags.EqualityConditionalOn /// Indicates that whether or not a generic type definition satisfies the comparison constraint is dependent on whether this type variable satisfies the comparison constraint. - member x.ComparisonConditionalOn = x.typar_flags.ComparisonConditionalOn + member x.ComparisonConditionalOn = typar_flags.ComparisonConditionalOn /// Indicates if the type variable has a static "head type" requirement, i.e. ^a variables used in FSharp.Core and member constraints. - member x.StaticReq = x.typar_flags.StaticReq + member x.StaticReq = typar_flags.StaticReq /// Indicates if the type inference variable was generated after an error when type checking expressions or patterns - member x.IsFromError = x.typar_flags.IsFromError + member x.IsFromError = typar_flags.IsFromError /// Indicates that whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) - member x.IsCompatFlex = x.typar_flags.IsCompatFlex + member x.IsCompatFlex = typar_flags.IsCompatFlex /// Set whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) - member x.SetIsCompatFlex b = x.typar_flags <- x.typar_flags.WithCompatFlex b + member x.SetIsCompatFlex b = typar_flags <- typar_flags.WithCompatFlex b /// Indicates whether a type variable can be instantiated by types or units-of-measure. - member x.Kind = x.typar_flags.Kind + member x.Kind = typar_flags.Kind /// Indicates whether a type variable is erased in compiled .NET IL code, i.e. whether it is a unit-of-measure variable member x.IsErased = match x.Kind with TyparKind.Type -> false | _ -> true /// The declared attributes of the type parameter. Empty for type inference variables and parameters from .NET. member x.Attribs = - match x.typar_opt_data with + match typar_opt_data with | Some optData -> optData.typar_attribs | _ -> [] /// Set the attributes on the type parameter member x.SetAttribs attribs = - match attribs, x.typar_opt_data with + match attribs, typar_opt_data with | [], None -> () | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = [] } when doc.IsEmpty -> - x.typar_opt_data <- None + typar_opt_data <- None | _, Some optData -> optData.typar_attribs <- attribs - | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } + | _ -> typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } /// Get the XML documetnation for the type parameter member x.XmlDoc = - match x.typar_opt_data with + match typar_opt_data with | Some optData -> optData.typar_xmldoc | _ -> XmlDoc.Empty /// Get the IL name of the type parameter member x.ILName = - match x.typar_opt_data with + match typar_opt_data with | Some optData -> optData.typar_il_name | _ -> None /// Set the IL name of the type parameter member x.SetILName il_name = - match x.typar_opt_data with + match typar_opt_data with | Some optData -> optData.typar_il_name <- il_name - | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = [] } + | _ -> typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = [] } /// Indicates the display name of a type variable member x.DisplayName = if x.Name = "?" then "?"+string x.Stamp else x.Name /// Adjusts the constraints associated with a type variable member x.SetConstraints cs = - match cs, x.typar_opt_data with + match cs, typar_opt_data with | [], None -> () | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [] } when doc.IsEmpty -> - x.typar_opt_data <- None + typar_opt_data <- None | _, Some optData -> optData.typar_constraints <- cs - | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = [] } + | _ -> typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = [] } /// Creates a type variable that contains empty data, and is not yet linked. Only used during unpickling of F# metadata. - static member NewUnlinked() : Typar = - { typar_id = Unchecked.defaultof<_> - typar_flags = Unchecked.defaultof<_> - typar_stamp = -1L - typar_solution = Unchecked.defaultof<_> - typar_astype = Unchecked.defaultof<_> - typar_opt_data = Unchecked.defaultof<_> - id_suggestions = Dictionary(1) } + static member NewUnlinked() : Typar = + Typar( + Unchecked.defaultof<_>, + Unchecked.defaultof<_>, + -1L, + Unchecked.defaultof<_>, + Unchecked.defaultof<_>, + Unchecked.defaultof<_> + ) /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. static member New (data: TyparData) : Typar = data /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. - member x.Link (tg: TyparData) = - x.typar_id <- tg.typar_id - x.typar_flags <- tg.typar_flags - x.typar_stamp <- tg.typar_stamp - x.typar_solution <- tg.typar_solution - match tg.typar_opt_data with + member x.Link (tg: TyparData) = + typar_id <- tg.TyparId + typar_flags <- tg.Flags + typar_stamp <- tg.Stamp + typar_solution <- tg.Solution + match tg.OptionalData with | Some tg -> let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs } - x.typar_opt_data <- Some optData + typar_opt_data <- Some optData | None -> () /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. member x.AsType = - let ty = x.typar_astype + let ty = typar_astype match box ty with | null -> let ty2 = TType_var (x, 0uy) - x.typar_astype <- ty2 + typar_astype <- ty2 ty2 | _ -> ty /// Indicates if a type variable has been linked. Only used during unpickling of F# metadata. - member x.IsLinked = x.typar_stamp <> -1L + member x.IsLinked = typar_stamp <> -1L /// Indicates if a type variable has been solved. member x.IsSolved = @@ -2290,36 +2307,53 @@ type Typar = | _ -> true /// Sets the identifier associated with a type variable - member x.SetIdent id = x.typar_id <- id - + member x.SetIdent id = + // BindTypars from PostInferenceChecks can be called by multiple threads (when graph based type-checking is enabled). + lock lockObj (fun () -> + match typar_id, id with + | TyparId.PrettyTyparName(originalIdent, oldIndex, _), + TyparId.PrettyTyparName(_, newIndex, newIdent) when newIndex < oldIndex -> + // Overwrite the ident when a file with a lower index tries to use a pretty name. + // This is to match the behaviour of sequential type-checking in graph based type-checking. + typar_id <- TyparId.PrettyTyparName(originalIdent, newIndex, newIdent) + | TyparId.PrettyTyparName _, TyparId.PrettyTyparName _ -> () + | _ -> + typar_id <- id + ) + + member _.SetSolution solution = + typar_solution <- Some solution + + member _.ClearSolution() = typar_solution <- None + /// Sets the rigidity of a type variable member x.SetRigidity b = - let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, b, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) + let flags = typar_flags + typar_flags <- TyparFlags(flags.Kind, b, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) /// Sets whether a type variable is compiler generated member x.SetCompilerGenerated b = - let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, b, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) + let flags = typar_flags + typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, b, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) /// Sets whether a type variable has a static requirement member x.SetStaticReq b = - x.typar_flags <- x.typar_flags.WithStaticReq(b) + typar_flags <- typar_flags.WithStaticReq(b) /// Sets whether a type variable is required at runtime member x.SetDynamicReq b = - let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, b, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) + let flags = typar_flags + typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, b, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) /// Sets whether the equality constraint of a type definition depends on this type variable member x.SetEqualityDependsOn b = - let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, b, flags.ComparisonConditionalOn) + let flags = typar_flags + typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, b, flags.ComparisonConditionalOn) /// Sets whether the comparison constraint of a type definition depends on this type variable member x.SetComparisonDependsOn b = - let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, b) + let flags = typar_flags + typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, b) [] member x.DebugText = x.ToString() @@ -5831,17 +5865,18 @@ type Construct() = /// Create a new type parameter node static member NewTypar (kind, rigid, SynTypar(id, staticReq, isCompGen), isFromError, dynamicReq, attribs, eqDep, compDep) = - Typar.New - { typar_id = id - typar_stamp = newStamp() - typar_flags= TyparFlags(kind, rigid, isFromError, isCompGen, staticReq, dynamicReq, eqDep, compDep) - typar_solution = None - typar_astype = Unchecked.defaultof<_> - typar_opt_data = + Typar.New ( + Typar( + TyparId.Initial id, + TyparFlags(kind, rigid, isFromError, isCompGen, staticReq, dynamicReq, eqDep, compDep), + newStamp(), + None, + Unchecked.defaultof<_>, match attribs with | [] -> None | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } - id_suggestions = Dictionary(0) } + ) + ) /// Create a new type parameter node for a declared type parameter static member NewRigidTypar nm m = diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 225d074b54d..69125427a29 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -1442,35 +1442,37 @@ type TyparOptionalData = type TyparData = Typar -/// A declared generic type/measure parameter, or a type/measure inference variable. +/// Wrapper around Ident to deal with various Typar.Id updates. +[] +type TyparId = + /// Used for new creations, when unpickling or when we use the same id in the signature during conformance. + | Initial of Ident + /// PrettyTyparName + | PrettyTyparName of originalIdent: Ident * currentIndex: int * currentIdent: Ident + +/// A declared generic type/measure parameter, or a type/measure inference variable. [] type Typar = - { - - /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation - /// The identifier for the type parameter - mutable typar_id: Syntax.Ident - - /// The flag data for the type parameter - mutable typar_flags: TyparFlags - - /// The unique stamp of the type parameter - /// MUTABILITY: for linking when unpickling - mutable typar_stamp: Stamp - - /// An inferred equivalence for a type inference variable. - mutable typar_solution: TType option - - /// A cached TAST type used when this type variable is used as type. - mutable typar_astype: TType - - /// The optional data for the type parameter - mutable typar_opt_data: TyparOptionalData option - - /// When type-checking using the graph method, multiple proposals for the typar_id can be found concurrently. - /// We would pick the ident with the lowest file index value (int), as that is the name the sequential type-checking would pick. - id_suggestions: Dictionary - } + /// + /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation. + /// The identifier for the type parameter. + /// + /// The flag data for the type parameter. + /// + /// The unique stamp of the type parameter + /// MUTABILITY: for linking when unpickling + /// + /// An inferred equivalence for a type inference variable. + /// A cached TAST type used when this type variable is used as type. + /// The optional data for the type parameter. + new: + typar_id: TyparId * + typar_flags: TyparFlags * + typar_stamp: Stamp * + typar_solution: TType option * + typar_astype: TType * + typar_opt_data: TyparOptionalData option -> + Typar /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. static member New: data: TyparData -> Typar @@ -1503,7 +1505,7 @@ type Typar = member SetILName: il_name: string option -> unit /// Sets the identifier associated with a type variable - member SetIdent: id: Syntax.Ident -> unit + member SetIdent: id: TyparId -> unit /// Set whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) member SetIsCompatFlex: b: bool -> unit @@ -1514,6 +1516,10 @@ type Typar = /// Sets whether a type variable has a static requirement member SetStaticReq: b: Syntax.TyparStaticReq -> unit + member SetSolution: solution: TType -> unit + + member ClearSolution: unit -> unit + override ToString: unit -> string /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. @@ -1546,6 +1552,12 @@ type Typar = /// The identifier for a type parameter definition member Id: Syntax.Ident + member TyparId: TyparId + + member Flags: TyparFlags + + member OptionalData: TyparOptionalData option + /// Indicates that whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) member IsCompatFlex: bool diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index c9c9529ffc8..a2725265292 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -197,18 +197,15 @@ let mkTyparTy (tp: Typar) = // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. let copyTypar clearStaticReq (tp: Typar) = - let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs }) - let flags = if clearStaticReq then tp.typar_flags.WithStaticReq(TyparStaticReq.None) else tp.typar_flags - Typar.New { typar_id = tp.typar_id - typar_flags = flags - typar_stamp = newStamp() - typar_solution = tp.typar_solution - typar_astype = Unchecked.defaultof<_> - // Be careful to clone the mutable optional data too - typar_opt_data = optData - id_suggestions = tp.id_suggestions } - -let copyTypars clearStaticReq tps = List.map (copyTypar clearStaticReq) tps + let optData = tp.OptionalData |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs }) + let flags = if clearStaticReq then tp.Flags.WithStaticReq(TyparStaticReq.None) else tp.Flags + Typar.New ( + Typar(tp.TyparId, flags, newStamp(), tp.Solution, Unchecked.defaultof<_>, + // Be careful to clone the mutable optional data too + optData) + ) + +let copyTypars clearStaticReq (tps: Typars) = List.map (copyTypar clearStaticReq) tps //-------------------------------------------------------------------------- // Inference variables @@ -223,8 +220,7 @@ let tryShortcutSolvedUnitPar canShortcut (r: Typar) = | Measure.Var r2 -> match r2.Solution with | None -> () - | Some _ as soln -> - r.typar_solution <- soln + | Some soln -> r.SetSolution soln | _ -> () unt | _ -> @@ -249,8 +245,7 @@ let rec stripTyparEqnsAux canShortcut ty = | TType_var (r2, _) when r2.Constraints.IsEmpty -> match r2.Solution with | None -> () - | Some _ as soln2 -> - r.typar_solution <- soln2 + | Some soln2 -> r.SetSolution soln2 | _ -> () stripTyparEqnsAux canShortcut soln | None -> diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index a6ce02a1c29..6db478d482d 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -155,7 +155,7 @@ let mkTyparInst (typars: Typars) tyargs = (List.zip typars tyargs: TyparInstantiation) let generalizeTypar tp = mkTyparTy tp -let generalizeTypars tps = List.map generalizeTypar tps +let generalizeTypars (tps: Typars) = List.map generalizeTypar tps let rec remapTypeAux (tyenv: Remap) (ty: TType) = let ty = stripTyparEqns ty @@ -567,7 +567,7 @@ let tryNormalizeMeasureInType g ty = | TType_measure (Measure.Var v) -> match v.Solution with | Some (TType_measure ms) -> - v.typar_solution <- Some (TType_measure (normalizeMeasure g ms)) + v.SetSolution(TType_measure (normalizeMeasure g ms)) ty | _ -> ty | _ -> ty @@ -938,10 +938,10 @@ type TypeEquivEnv with member aenv.BindTyparsToTypes tps1 tys2 = { aenv with EquivTypars = (tps1, tys2, aenv.EquivTypars) |||> List.foldBack2 (fun tp ty tpmap -> tpmap.Add(tp, ty)) } - member aenv.BindEquivTypars tps1 tps2 = + member aenv.BindEquivTypars (tps1: Typars) (tps2: Typars) = aenv.BindTyparsToTypes tps1 (List.map mkTyparTy tps2) - static member FromTyparInst tpinst = + static member FromTyparInst (tpinst: TyparInstantiation) = let tps, tys = List.unzip tpinst TypeEquivEnv.Empty.BindTyparsToTypes tps tys @@ -2324,7 +2324,7 @@ and accFreeInVal opts (v: Val) acc = accFreeInType opts v.val_type acc let freeInTypes opts tys = accFreeInTypes opts tys emptyFreeTyvars let freeInVal opts v = accFreeInVal opts v emptyFreeTyvars let freeInTyparConstraints opts v = accFreeInTyparConstraints opts v emptyFreeTyvars -let accFreeInTypars opts tps acc = List.foldBack (accFreeTyparRef opts) tps acc +let accFreeInTypars opts (tps: Typars) acc = List.foldBack (accFreeTyparRef opts) tps acc let rec addFreeInModuleTy (mtyp: ModuleOrNamespaceType) acc = QueueList.foldBack (typeOfVal >> accFreeInType CollectAllNoCaching) mtyp.AllValsAndMembers @@ -2791,8 +2791,10 @@ module PrettyTypes = // Finally, we skip any names already in use let NeedsPrettyTyparName (tp: Typar) = tp.IsCompilerGenerated && - tp.ILName.IsNone && - (tp.typar_id.idText = unassignedTyparName) + tp.ILName.IsNone && + match tp.TyparId with + | TyparId.PrettyTyparName _ -> true + | _ -> tp.Name = unassignedTyparName let PrettyTyparNames pred alreadyInUse tps = let rec choose (tps: Typar list) (typeIndex, measureIndex) acc = @@ -8703,7 +8705,7 @@ and tyargsEnc g (gtpsType, gtpsMethod) args = | [a] when (match (stripTyEqns g a) with TType_measure _ -> true | _ -> false) -> "" // float should appear as just "float" in the generated .XML xmldoc file | _ -> angleEnc (commaEncs (List.map (typeEnc g (gtpsType, gtpsMethod)) args)) -let XmlDocArgsEnc g (gtpsType, gtpsMethod) argTys = +let XmlDocArgsEnc g (gtpsType: Typars, gtpsMethod: Typars) argTys = if isNil argTys then "" else "(" + String.concat "," (List.map (typeEnc g (gtpsType, gtpsMethod)) argTys) + ")" diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index c6cf1c303a8..c04e9298f9f 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -979,7 +979,7 @@ module PrettyTypes = val NewPrettyTypars: TyparInstantiation -> Typars -> string list -> Typars * TyparInstantiation - val PrettyTyparNames: (Typar -> bool) -> string list -> Typars -> string list + val PrettyTyparNames: pred: (Typar -> bool) -> alreadyInUse: string list -> tps: Typars -> string list val PrettifyType: TcGlobals -> TType -> TType * TyparConstraintsWithTypars diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index ebfa690c6e5..bacd5dffdc2 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1596,7 +1596,7 @@ let p_tyar_spec_data (x: Typar) st = p_int64 p_tyar_constraints p_xmldoc - (x.typar_id, x.Attribs, int64 x.typar_flags.PickledBits, x.Constraints, x.XmlDoc) st + (x.Id, x.Attribs, int64 x.Flags.PickledBits, x.Constraints, x.XmlDoc) st let p_tyar_spec (x: Typar) st = //Disabled, workaround for bug 2721: if x.Rigidity <> TyparRigidity.Rigid then warning(Error(sprintf "p_tyar_spec: typar#%d is not rigid" x.Stamp, x.Range)) @@ -1607,16 +1607,16 @@ let p_tyar_specs = (p_list p_tyar_spec) let u_tyar_spec_data st = let a, c, d, e, g = u_tup5 u_ident u_attribs u_int64 u_tyar_constraints u_xmldoc st - { typar_id=a - typar_stamp=newStamp() - typar_flags=TyparFlags(int32 d) - typar_solution=None - typar_astype= Unchecked.defaultof<_> - typar_opt_data= + Typar( + TyparId.Initial a, + TyparFlags(int32 d), + newStamp(), + None, + Unchecked.defaultof<_>, match g, e, c with | doc, [], [] when doc.IsEmpty -> None | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c } - id_suggestions = Dictionary(0) } + ) let u_tyar_spec st = u_osgn_decl st.itypars u_tyar_spec_data st From 23710c518a52a8a796671ef0acc16445c0036649 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 15 Mar 2023 15:41:55 +0100 Subject: [PATCH 04/14] Avoid null pointer from Unchecked.defaultof. --- src/Compiler/TypedTree/TypedTree.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 7be1a861673..6d59ab929ed 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2264,7 +2264,7 @@ type Typar /// Creates a type variable that contains empty data, and is not yet linked. Only used during unpickling of F# metadata. static member NewUnlinked() : Typar = Typar( - Unchecked.defaultof<_>, + TyparId.Initial(Unchecked.defaultof<_>), Unchecked.defaultof<_>, -1L, Unchecked.defaultof<_>, From 6a91cd0b058ef224b042222da5e444972ef6a4a9 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 16 Mar 2023 13:54:51 +0100 Subject: [PATCH 05/14] Extract typed tree serialization to separate module. --- src/Compiler/Driver/CompilerImports.fs | 2 +- src/Compiler/FSharp.Compiler.Service.fsproj | 2 + .../TypedTree/TypeTreeSerialization.fs | 112 ++++++++++++++++++ .../TypedTree/TypeTreeSerialization.fsi | 8 ++ src/Compiler/TypedTree/TypedTreeOps.fs | 103 ---------------- src/Compiler/TypedTree/TypedTreeOps.fsi | 3 - 6 files changed, 123 insertions(+), 107 deletions(-) create mode 100644 src/Compiler/TypedTree/TypeTreeSerialization.fs create mode 100644 src/Compiler/TypedTree/TypeTreeSerialization.fsi diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index b8ca157ad60..6021bb659ca 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -143,7 +143,7 @@ let WriteSignatureData (tcConfig: TcConfig, tcGlobals, exportRemapping, ccu: Ccu |> Option.iter (fun outputFile -> let outputFile = FileSystem.GetFullPathShim(outputFile) let signatureDataFile = FileSystem.ChangeExtensionShim(outputFile, ".signature-data.json") - serializeEntity signatureDataFile mspec) + TypeTreeSerialization.serializeEntity signatureDataFile mspec) // For historical reasons, we use a different resource name for FSharp.Core, so older F# compilers // don't complain when they see the resource. diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 2558f69a431..77e18a2106c 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -283,6 +283,8 @@ + + diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fs b/src/Compiler/TypedTree/TypeTreeSerialization.fs new file mode 100644 index 00000000000..884ce21240f --- /dev/null +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fs @@ -0,0 +1,112 @@ +module FSharp.Compiler.TypeTreeSerialization + +open System.CodeDom.Compiler +open Internal.Utilities.Library + +open FSharp.Compiler.IO +open FSharp.Compiler.TypedTree + +type TypedTreeNode = + { + Kind: string + Name: string + Children: TypedTreeNode list + } + +let rec visitEntity (entity: Entity) : TypedTreeNode = + let kind = + if entity.IsModule then "module" + elif entity.IsNamespace then "namespace" + else "other" + + let children = + if not entity.IsModuleOrNamespace then + Seq.empty + else + seq { + yield! Seq.map visitEntity entity.ModuleOrNamespaceType.AllEntities + yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers + } + + { + Kind = kind + Name = entity.CompiledName + Children = Seq.toList children + } + +and visitVal (v: Val) : TypedTreeNode = + let children = + seq { + match v.ValReprInfo with + | None -> () + | Some reprInfo -> + yield! + reprInfo.ArgInfos + |> Seq.collect (fun argInfos -> + argInfos + |> Seq.map (fun argInfo -> + { + Name = argInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue "" + Kind = "ArgInfo" + Children = [] + })) + + yield! + v.Typars + |> Seq.map (fun typar -> + { + Name = typar.Name + Kind = "Typar" + Children = [] + }) + } + + { + Name = v.CompiledName None + Kind = "val" + Children = Seq.toList children + } + +let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma: bool) (node: TypedTreeNode) = + writer.WriteLine("{") + // Add indent after opening { + writer.Indent <- writer.Indent + 1 + + writer.WriteLine($"\"name\": \"{node.Name}\",") + writer.WriteLine($"\"kind\": \"{node.Kind}\",") + + if node.Children.IsEmpty then + writer.WriteLine("\"children\": []") + else + writer.WriteLine("\"children\": [") + + // Add indent after opening [ + writer.Indent <- writer.Indent + 1 + + node.Children + |> List.iteri (fun idx -> serializeNode writer (idx + 1 < node.Children.Length)) + + // Remove indent before closing ] + writer.Indent <- writer.Indent - 1 + writer.WriteLine("]") + + // Remove indent before closing } + writer.Indent <- writer.Indent - 1 + + if addTrailingComma then + writer.WriteLine("},") + else + writer.WriteLine("}") + +let rec serializeEntity path (entity: Entity) = + let root = visitEntity entity + use sw = new System.IO.StringWriter() + use writer = new IndentedTextWriter(sw) + serializeNode writer false root + writer.Flush() + let json = sw.ToString() + + use out = + FileSystem.OpenFileForWriteShim(path, fileMode = System.IO.FileMode.Create) + + out.WriteAllText(json) diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fsi b/src/Compiler/TypedTree/TypeTreeSerialization.fsi new file mode 100644 index 00000000000..22e9c417b54 --- /dev/null +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fsi @@ -0,0 +1,8 @@ +/// Helper code to serialize the typed tree to json +/// This code is invoked via the `--test:DumpSignatureData` flag. +module internal FSharp.Compiler.TypeTreeSerialization + +open FSharp.Compiler.TypedTree + +/// Serialize an entity to a very basic json structure. +val serializeEntity: path: string -> entity: Entity -> unit diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 12b488e4dc0..deb35e0d5ba 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -10499,106 +10499,3 @@ let tryAddExtensionAttributeIfNotAlreadyPresent match tryFindExtensionAttributeIn tryFindExtensionAttribute with | None -> entity | Some extensionAttrib -> { entity with entity_attribs = extensionAttrib :: entity.Attribs } - -type TypedTreeNode = - { - Kind: string - Name: string - Children: TypedTreeNode list - } - -let rec visitEntity (entity: Entity) : TypedTreeNode = - let kind = - if entity.IsModule then - "module" - elif entity.IsNamespace then - "namespace" - else - "other" - - let children = - if not entity.IsModuleOrNamespace then - Seq.empty - else - seq { - yield! Seq.map visitEntity entity.ModuleOrNamespaceType.AllEntities - yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers - } - - { - Kind = kind - Name = entity.CompiledName - Children = Seq.toList children - } - -and visitVal (v: Val) : TypedTreeNode = - let children = - seq { - match v.ValReprInfo with - | None -> () - | Some reprInfo -> - yield! - reprInfo.ArgInfos - |> Seq.collect (fun argInfos -> - argInfos - |> Seq.map (fun argInfo -> { - Name = argInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue "" - Kind = "ArgInfo" - Children = [] - }) - ) - - yield! - v.Typars - |> Seq.map (fun typar -> { - Name = typar.Name - Kind = "Typar" - Children = [] - }) - } - - { - Name = v.CompiledName None - Kind = "val" - Children = Seq.toList children - } - -let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma:bool) (node: TypedTreeNode) = - writer.WriteLine("{") - // Add indent after opening { - writer.Indent <- writer.Indent + 1 - - writer.WriteLine($"\"name\": \"{node.Name}\",") - writer.WriteLine($"\"kind\": \"{node.Kind}\",") - - if node.Children.IsEmpty then - writer.WriteLine("\"children\": []") - else - writer.WriteLine("\"children\": [") - - // Add indent after opening [ - writer.Indent <- writer.Indent + 1 - - node.Children - |> List.iteri (fun idx -> serializeNode writer (idx + 1 < node.Children.Length)) - - // Remove indent before closing ] - writer.Indent <- writer.Indent - 1 - writer.WriteLine("]") - - // Remove indent before closing } - writer.Indent <- writer.Indent - 1 - if addTrailingComma then - writer.WriteLine("},") - else - writer.WriteLine("}") - -let rec serializeEntity path (entity: Entity) = - let root = visitEntity entity - use sw = new System.IO.StringWriter() - use writer = new IndentedTextWriter(sw) - serializeNode writer false root - writer.Flush() - let json = sw.ToString() - use out = FileSystem.OpenFileForWriteShim(path, fileMode = System.IO.FileMode.Create) - out.WriteAllText(json) diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index c04e9298f9f..3d08c973e1c 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -2695,6 +2695,3 @@ val (|EmptyModuleOrNamespaces|_|): /// Add an System.Runtime.CompilerServices.ExtensionAttribute to the Entity if found via predicate and not already present. val tryAddExtensionAttributeIfNotAlreadyPresent: tryFindExtensionAttributeIn: ((Attrib list -> Attrib option) -> Attrib option) -> entity: Entity -> Entity - -/// Serialize an entity to a very basic json structure. -val serializeEntity: path: string -> entity: Entity -> unit From 2c9dac8175353931210822a1fe30ebe5ff52c5f6 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 16 Mar 2023 14:14:00 +0100 Subject: [PATCH 06/14] Add flags to json. --- src/Compiler/TypedTree/TypeTreeSerialization.fs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fs b/src/Compiler/TypedTree/TypeTreeSerialization.fs index 884ce21240f..69b4bba511a 100644 --- a/src/Compiler/TypedTree/TypeTreeSerialization.fs +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fs @@ -11,6 +11,7 @@ type TypedTreeNode = Kind: string Name: string Children: TypedTreeNode list + Flags: int64 option } let rec visitEntity (entity: Entity) : TypedTreeNode = @@ -32,6 +33,7 @@ let rec visitEntity (entity: Entity) : TypedTreeNode = Kind = kind Name = entity.CompiledName Children = Seq.toList children + Flags = Some entity.entity_flags.PickledBits } and visitVal (v: Val) : TypedTreeNode = @@ -49,6 +51,7 @@ and visitVal (v: Val) : TypedTreeNode = Name = argInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue "" Kind = "ArgInfo" Children = [] + Flags = None })) yield! @@ -58,6 +61,7 @@ and visitVal (v: Val) : TypedTreeNode = Name = typar.Name Kind = "Typar" Children = [] + Flags = Some typar.Flags.PickledBits }) } @@ -65,6 +69,7 @@ and visitVal (v: Val) : TypedTreeNode = Name = v.CompiledName None Kind = "val" Children = Seq.toList children + Flags = Some v.val_flags.PickledBits } let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma: bool) (node: TypedTreeNode) = @@ -75,6 +80,9 @@ let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma: bool) (nod writer.WriteLine($"\"name\": \"{node.Name}\",") writer.WriteLine($"\"kind\": \"{node.Kind}\",") + node.Flags + |> Option.iter (fun flags -> writer.WriteLine($"\"flags\":%i{flags},")) + if node.Children.IsEmpty then writer.WriteLine("\"children\": []") else From e62a5ab94c7069cbee6d8ce4a62d91b2b6bd4b0b Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 16 Mar 2023 14:33:32 +0100 Subject: [PATCH 07/14] Add range to json. --- .../TypedTree/TypeTreeSerialization.fs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fs b/src/Compiler/TypedTree/TypeTreeSerialization.fs index 69b4bba511a..d02d0348bb6 100644 --- a/src/Compiler/TypedTree/TypeTreeSerialization.fs +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fs @@ -1,6 +1,7 @@ module FSharp.Compiler.TypeTreeSerialization open System.CodeDom.Compiler +open FSharp.Compiler.Text open Internal.Utilities.Library open FSharp.Compiler.IO @@ -12,6 +13,7 @@ type TypedTreeNode = Name: string Children: TypedTreeNode list Flags: int64 option + Range: range option } let rec visitEntity (entity: Entity) : TypedTreeNode = @@ -34,6 +36,7 @@ let rec visitEntity (entity: Entity) : TypedTreeNode = Name = entity.CompiledName Children = Seq.toList children Flags = Some entity.entity_flags.PickledBits + Range = Some entity.Range } and visitVal (v: Val) : TypedTreeNode = @@ -52,6 +55,7 @@ and visitVal (v: Val) : TypedTreeNode = Kind = "ArgInfo" Children = [] Flags = None + Range = None })) yield! @@ -62,6 +66,7 @@ and visitVal (v: Val) : TypedTreeNode = Kind = "Typar" Children = [] Flags = Some typar.Flags.PickledBits + Range = Some typar.Range }) } @@ -70,18 +75,23 @@ and visitVal (v: Val) : TypedTreeNode = Kind = "val" Children = Seq.toList children Flags = Some v.val_flags.PickledBits + Range = Some v.Range } +let write (writer: IndentedTextWriter) key value = + writer.WriteLine($"\"%s{key}\": \"{value}\",") + let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma: bool) (node: TypedTreeNode) = writer.WriteLine("{") // Add indent after opening { writer.Indent <- writer.Indent + 1 - writer.WriteLine($"\"name\": \"{node.Name}\",") - writer.WriteLine($"\"kind\": \"{node.Kind}\",") + write writer "name" node.Name + write writer "kind" node.Kind + + node.Flags |> Option.iter (write writer "flags") - node.Flags - |> Option.iter (fun flags -> writer.WriteLine($"\"flags\":%i{flags},")) + node.Range |> Option.iter (write writer "range") if node.Children.IsEmpty then writer.WriteLine("\"children\": []") From 0d88a251e2528e7683c4cab0edb4d8c9946507eb Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 16 Mar 2023 15:04:46 +0100 Subject: [PATCH 08/14] Add more data to signature json. --- .../TypedTree/TypeTreeSerialization.fs | 44 ++++++++++++++++--- 1 file changed, 38 insertions(+), 6 deletions(-) diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fs b/src/Compiler/TypedTree/TypeTreeSerialization.fs index d02d0348bb6..2f83edeed54 100644 --- a/src/Compiler/TypedTree/TypeTreeSerialization.fs +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fs @@ -14,22 +14,33 @@ type TypedTreeNode = Children: TypedTreeNode list Flags: int64 option Range: range option + CompilationPath: CompilationPath option } let rec visitEntity (entity: Entity) : TypedTreeNode = let kind = if entity.IsModule then "module" elif entity.IsNamespace then "namespace" + elif entity.IsUnionTycon then "union" + elif entity.IsRecordTycon then "record" + elif entity.IsFSharpClassTycon then "class" + elif entity.IsErased then "erased" + elif entity.IsEnumTycon then "enum" + elif entity.IsTypeAbbrev then "abbreviation" + elif entity.IsFSharpObjectModelTycon then "objectModel" + elif entity.IsFSharpException then "exception" + elif entity.IsFSharpDelegateTycon then "delegate" + elif entity.IsFSharpInterfaceTycon then "interface" else "other" let children = - if not entity.IsModuleOrNamespace then - Seq.empty - else - seq { + seq { + if entity.IsModuleOrNamespace then yield! Seq.map visitEntity entity.ModuleOrNamespaceType.AllEntities yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers - } + + yield! visitAttributes entity.Attribs + } { Kind = kind @@ -37,11 +48,14 @@ let rec visitEntity (entity: Entity) : TypedTreeNode = Children = Seq.toList children Flags = Some entity.entity_flags.PickledBits Range = Some entity.Range + CompilationPath = Some entity.CompilationPath } and visitVal (v: Val) : TypedTreeNode = let children = seq { + yield! visitAttributes v.Attribs + match v.ValReprInfo with | None -> () | Some reprInfo -> @@ -56,6 +70,7 @@ and visitVal (v: Val) : TypedTreeNode = Children = [] Flags = None Range = None + CompilationPath = None })) yield! @@ -67,6 +82,7 @@ and visitVal (v: Val) : TypedTreeNode = Children = [] Flags = Some typar.Flags.PickledBits Range = Some typar.Range + CompilationPath = None }) } @@ -76,8 +92,22 @@ and visitVal (v: Val) : TypedTreeNode = Children = Seq.toList children Flags = Some v.val_flags.PickledBits Range = Some v.Range + CompilationPath = None + } + +and visitAttribute (a: Attrib) : TypedTreeNode = + { + Kind = "attribute" + Name = a.TyconRef.CompiledName + Children = List.empty + Flags = None + Range = Some a.Range + // I don't think the tycon ComplicationPath is relevant here. + CompilationPath = None } +and visitAttributes (attribs: Attribs) : TypedTreeNode seq = List.map visitAttribute attribs + let write (writer: IndentedTextWriter) key value = writer.WriteLine($"\"%s{key}\": \"{value}\",") @@ -90,9 +120,11 @@ let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma: bool) (nod write writer "kind" node.Kind node.Flags |> Option.iter (write writer "flags") - node.Range |> Option.iter (write writer "range") + node.CompilationPath + |> Option.iter (fun cp -> cp.MangledPath |> String.concat "," |> write writer "compilationPath") + if node.Children.IsEmpty then writer.WriteLine("\"children\": []") else From 48fb1f348664b948e00d0569690d4057cf1109fd Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 20 Mar 2023 10:39:30 +0100 Subject: [PATCH 09/14] Add more info to signature data serialization --- .../TypedTree/TypeTreeSerialization.fs | 42 ++++++++++++------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fs b/src/Compiler/TypedTree/TypeTreeSerialization.fs index 2f83edeed54..ec8f1e65f7c 100644 --- a/src/Compiler/TypedTree/TypeTreeSerialization.fs +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fs @@ -37,8 +37,8 @@ let rec visitEntity (entity: Entity) : TypedTreeNode = seq { if entity.IsModuleOrNamespace then yield! Seq.map visitEntity entity.ModuleOrNamespaceType.AllEntities - yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers + yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers yield! visitAttributes entity.Attribs } @@ -58,27 +58,29 @@ and visitVal (v: Val) : TypedTreeNode = match v.ValReprInfo with | None -> () - | Some reprInfo -> + | Some (ValReprInfo (typars, args, result)) -> + yield! args |> Seq.collect id |> Seq.map visitArgReprInfo + + yield visitArgReprInfo result + yield! - reprInfo.ArgInfos - |> Seq.collect (fun argInfos -> - argInfos - |> Seq.map (fun argInfo -> - { - Name = argInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue "" - Kind = "ArgInfo" - Children = [] - Flags = None - Range = None - CompilationPath = None - })) + typars + |> List.map (fun (TyparReprInfo (ident, _kind)) -> + { + Name = ident.idText + Kind = "typar" + Children = [] + Flags = None + Range = Some ident.idRange + CompilationPath = None + }) yield! v.Typars |> Seq.map (fun typar -> { Name = typar.Name - Kind = "Typar" + Kind = "typar" Children = [] Flags = Some typar.Flags.PickledBits Range = Some typar.Range @@ -108,6 +110,16 @@ and visitAttribute (a: Attrib) : TypedTreeNode = and visitAttributes (attribs: Attribs) : TypedTreeNode seq = List.map visitAttribute attribs +and visitArgReprInfo (argReprInfo: ArgReprInfo) = + { + Name = argReprInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue "" + Kind = "ArgInfo" + Children = [] + Flags = None + Range = None + CompilationPath = None + } + let write (writer: IndentedTextWriter) key value = writer.WriteLine($"\"%s{key}\": \"{value}\",") From ff485e5091744758b50accb854159b3da6aae8bb Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 21 Mar 2023 14:48:04 +0100 Subject: [PATCH 10/14] Revert most code. --- src/Compiler/Checking/CheckDeclarations.fs | 3 +- src/Compiler/Checking/CheckDeclarations.fsi | 1 - src/Compiler/Checking/CheckExpressions.fs | 2 +- src/Compiler/Checking/ConstraintSolver.fs | 10 +- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 25 +- src/Compiler/Checking/PostInferenceChecks.fsi | 1 - src/Compiler/Checking/SignatureConformance.fs | 2 +- src/Compiler/Driver/ParseAndCheckInputs.fs | 11 +- src/Compiler/Optimize/Optimizer.fs | 9 +- src/Compiler/TypedTree/TypedTree.fs | 217 +++++++----------- src/Compiler/TypedTree/TypedTree.fsi | 64 ++---- src/Compiler/TypedTree/TypedTreeBasics.fs | 26 ++- src/Compiler/TypedTree/TypedTreeOps.fs | 18 +- src/Compiler/TypedTree/TypedTreePickle.fs | 17 +- 15 files changed, 165 insertions(+), 243 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index a6aa9adf3e4..7ee34cb5cd8 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5365,7 +5365,6 @@ let CheckOneImplFile env, rootSigOpt: ModuleOrNamespaceType option, synImplFile, - fileIdx, diagnosticOptions) = let (ParsedImplFileInput (fileName, isScript, qualNameOfFile, scopedPragmas, _, implFileFrags, isLastCompiland, _, _)) = synImplFile @@ -5469,7 +5468,7 @@ let CheckOneImplFile PostTypeCheckSemanticChecks.CheckImplFile (g, cenv.amap, reportErrors, cenv.infoReader, env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, - implFileTy, implFileContents, extraAttribs, fileIdx, isLastCompiland, + implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) with exn -> diff --git a/src/Compiler/Checking/CheckDeclarations.fsi b/src/Compiler/Checking/CheckDeclarations.fsi index 09a88163ff8..fb4679f2438 100644 --- a/src/Compiler/Checking/CheckDeclarations.fsi +++ b/src/Compiler/Checking/CheckDeclarations.fsi @@ -60,7 +60,6 @@ val CheckOneImplFile: TcEnv * ModuleOrNamespaceType option * ParsedImplFileInput * - FileIndex option * FSharpDiagnosticOptions -> Cancellable diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index d899ba63787..a1cb3b8063b 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -11984,7 +11984,7 @@ and FixupLetrecBind (cenv: cenv) denv generalizedTyparsForRecursiveBlock (bind: // TcLetrecBindings - for both expressions and class-let-rec-declarations //------------------------------------------------------------------------ -and unionGeneralizedTypars (typarSets: Typars list) = List.foldBack (ListSet.unionFavourRight typarEq) typarSets [] +and unionGeneralizedTypars typarSets = List.foldBack (ListSet.unionFavourRight typarEq) typarSets [] and TcLetrecBindings overridesOK (cenv: cenv) env tpenv (binds, bindsm, scopem) = diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 0e1bde44aca..6b0ef85d5e8 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -693,8 +693,8 @@ let SubstMeasure (r: Typar) ms = if r.Rigidity = TyparRigidity.Rigid then error(InternalError("SubstMeasure: rigid", r.Range)) if r.Kind = TyparKind.Type then error(InternalError("SubstMeasure: kind=type", r.Range)) - match r.Solution with - | None -> r.SetSolution(TType_measure ms) + match r.typar_solution with + | None -> r.typar_solution <- Some (TType_measure ms) | Some _ -> error(InternalError("already solved", r.Range)) let rec TransactStaticReq (csenv: ConstraintSolverEnv) (trace: OptionalTrace) (tpr: Typar) req = @@ -993,7 +993,7 @@ let rec SolveTyparEqualsTypePart1 (csenv: ConstraintSolverEnv) m2 (trace: Option // Record the solution before we solve the constraints, since // We may need to make use of the equation when solving the constraints. // Record a entry in the undo trace if one is provided - trace.Exec (fun () -> r.SetSolution(ty)) (fun () -> r.ClearSolution()) + trace.Exec (fun () -> r.typar_solution <- Some ty) (fun () -> r.typar_solution <- None) } and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (r: Typar) ty = trackErrors { @@ -3695,7 +3695,7 @@ let ChooseTyparSolutionAndSolve css denv tp = (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult -let CheckDeclaredTypars denv css m (typars1: Typars) (typars2: Typars) = +let CheckDeclaredTypars denv css m typars1 typars2 = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> @@ -3707,7 +3707,7 @@ let CheckDeclaredTypars denv css m (typars1: Typars) (typars2: Typars) = ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let CanonicalizePartialInferenceProblem css denv m (tps: Typars) = +let CanonicalizePartialInferenceProblem css denv m tps = // Canonicalize constraints prior to generalization let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 58113e4e351..570928368a8 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -4045,7 +4045,7 @@ let ResolveExprDotLongIdentAndComputeRange (sink: TcResultsSink) (ncenv: NameRes //------------------------------------------------------------------------- /// A generator of type instantiations used when no more specific type instantiation is known. -let FakeInstantiationGenerator (_m: range) (gps: Typars) = List.map mkTyparTy gps +let FakeInstantiationGenerator (_m: range) gps = List.map mkTyparTy gps // note: using local refs is ok since it is only used by VS let ItemForModuleOrNamespaceRef v = Item.ModuleOrNamespaces [v] diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index a4d69f8964c..bb833eebabd 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -102,11 +102,6 @@ type env = /// Are we expecting a resumable code block etc resumableCode: Resumable - - /// Do we know the current file index? - /// If we do this means we are processing type-checking files using the parallel graph mode, - /// and should account for naming the typars according to the lowest file index. - fileIndex: int option } override _.ToString() = "" @@ -116,21 +111,14 @@ let BindTypar env (tp: Typar) = boundTyparNames = tp.Name :: env.boundTyparNames boundTypars = env.boundTypars.Add (tp, ()) } -let BindTypars g env (tps: Typars) = +let BindTypars g env (tps: Typar list) = let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps if isNil tps then env else // Here we mutate to provide better names for generalized type parameters let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps - (tps, nms) - ||> List.iter2 (fun tp nm -> - let typar_id = ident (nm, tp.Range) - if PrettyTypes.NeedsPrettyTyparName tp then - match env.fileIndex with - | None -> - tp.SetIdent(TyparId.Initial(typar_id)) - | Some idx -> - tp.SetIdent(TyparId.PrettyTyparName(typar_id, idx, typar_id)) - ) + (tps, nms) ||> List.iter2 (fun tp nm -> + if PrettyTypes.NeedsPrettyTyparName tp then + tp.typar_id <- ident (nm, tp.Range)) List.fold BindTypar env tps /// Set the set of vals which are arguments in the active lambda. We are allowed to return @@ -2611,7 +2599,7 @@ let CheckImplFileContents cenv env implFileTy implFileContents = let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } CheckDefnInModule cenv env implFileContents -let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, fileIndex, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = +let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = let cenv = { g = g reportErrors = reportErrors @@ -2652,8 +2640,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v external=false returnScope = 0 isInAppExpr = false - resumableCode = Resumable.None - fileIndex = fileIndex } + resumableCode = Resumable.None } CheckImplFileContents cenv env implFileTy implFileContents CheckAttribs cenv env extraAttribs diff --git a/src/Compiler/Checking/PostInferenceChecks.fsi b/src/Compiler/Checking/PostInferenceChecks.fsi index 14b537ec483..6e289af71c8 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fsi +++ b/src/Compiler/Checking/PostInferenceChecks.fsi @@ -23,7 +23,6 @@ val CheckImplFile: implFileTy: ModuleOrNamespaceType * implFileContents: ModuleOrNamespaceContents * extraAttribs: Attribs * - fileIndex: int option * (bool * bool) * isInternalTestSpanStackReferring: bool -> bool * StampMap diff --git a/src/Compiler/Checking/SignatureConformance.fs b/src/Compiler/Checking/SignatureConformance.fs index cf610c32724..cf2d2a0bc13 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -133,7 +133,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m)) // Adjust the actual type parameter name to look like the signature - implTypar.SetIdent (TyparId.Initial(mkSynId implTypar.Range sigTypar.Id.idText)) + implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText) // Mark it as "not compiler generated", now that we've got a good name for it implTypar.SetCompilerGenerated false diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 944322c9142..b011cc1971b 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1333,7 +1333,6 @@ let CheckOneInputAux tcState.tcsTcImplEnv, rootSigOpt, file, - None, tcConfig.diagnosticsOptions ) @@ -1482,7 +1481,7 @@ let CheckOneInputWithCallback tcSink, tcState: TcState, inp: ParsedInput, - idx: FileIndex): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * FileIndex) + _skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool) : Cancellable> = cancellable { try @@ -1572,7 +1571,6 @@ let CheckOneInputWithCallback tcState.tcsTcImplEnv, rootSigOpt, file, - Some idx, tcConfig.diagnosticsOptions ) @@ -1720,7 +1718,6 @@ let CheckMultipleInputsUsingGraphMode partialResult, (nextTcState, currentPriorErrors)) let processFile - (idx: FileIndex) ((input, logger): ParsedInput * DiagnosticsLogger) ((currentTcState, _currentPriorErrors): State) : Finisher = @@ -1729,7 +1726,7 @@ let CheckMultipleInputsUsingGraphMode let tcSink = TcResultsSink.NoSink let finisher = - CheckOneInputWithCallback(checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, idx) + CheckOneInputWithCallback(checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, false) |> Cancellable.runWithoutCancellation Finisher(fun (state: State) -> @@ -1756,7 +1753,7 @@ let CheckMultipleInputsUsingGraphMode processArtificialImplFile parsedInput state | NodeToTypeCheck.PhysicalFile idx -> let parsedInput, logger = inputsWithLoggers[idx] - processFile idx (parsedInput, logger) state + processFile (parsedInput, logger) state let state: State = tcState, priorErrors @@ -1786,7 +1783,7 @@ let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tc // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions let results, tcState = match tcConfig.typeCheckingConfig.Mode with - | TypeCheckingMode.Graph when (not tcConfig.isInteractive) -> + | TypeCheckingMode.Graph when (not tcConfig.isInteractive && not tcConfig.deterministic) -> CheckMultipleInputsUsingGraphMode( ctok, checkForErrors, diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 517a6fb2baf..343d911aa4d 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -604,12 +604,9 @@ let BindTyparsToUnknown (tps: Typar list) env = // However here we mutate to provide better names for generalized type parameters // The names chosen are 'a', 'b' etc. These are also the compiled names in the IL code let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) (env.typarInfos |> List.map (fun (tp, _) -> tp.Name) ) tps - (tps, nms) - ||> List.iter2 (fun tp nm -> - if PrettyTypes.NeedsPrettyTyparName tp then - // As the optimize phase is not happening in parallel, we can safely write the ident. - tp.SetIdent(TyparId.Initial(ident (nm, tp.Range))) - ) + (tps, nms) ||> List.iter2 (fun tp nm -> + if PrettyTypes.NeedsPrettyTyparName tp then + tp.typar_id <- ident (nm, tp.Range)) List.fold (fun sofar arg -> BindTypar arg UnknownTypeValue sofar) env tps let BindCcu (ccu: CcuThunk) mval env (_g: TcGlobals) = diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 6d59ab929ed..af37bf45c92 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2116,189 +2116,167 @@ type TyparOptionalData = type TyparData = Typar -[] -type TyparId = - | Initial of Ident - | PrettyTyparName of originalIdent: Ident * currentIndex: int * currentIdent: Ident - -/// A declared generic type/measure parameter, or a type/measure inference variable. -/// -/// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation. -/// The identifier for the type parameter. -/// -/// The flag data for the type parameter. -/// -/// The unique stamp of the type parameter -/// MUTABILITY: for linking when unpickling -/// -/// An inferred equivalence for a type inference variable. -/// A cached TAST type used when this type variable is used as type. -/// The optional data for the type parameter. +/// A declared generic type/measure parameter, or a type/measure inference variable. [] -type Typar - ( - typar_id: TyparId, - typar_flags: TyparFlags, - typar_stamp: Stamp, - typar_solution: TType option, - typar_astype: TType, - typar_opt_data: TyparOptionalData option - ) = - let mutable typar_id: TyparId = typar_id - let mutable typar_flags: TyparFlags = typar_flags - let mutable typar_stamp: Stamp = typar_stamp - let mutable typar_solution: TType option = typar_solution - let mutable typar_astype: TType = typar_astype - let mutable typar_opt_data: TyparOptionalData option = typar_opt_data - let lockObj = obj() +type Typar = + { + /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation + /// The identifier for the type parameter + mutable typar_id: Ident + + /// The flag data for the type parameter + mutable typar_flags: TyparFlags + + /// The unique stamp of the type parameter + /// MUTABILITY: for linking when unpickling + mutable typar_stamp: Stamp + + /// An inferred equivalence for a type inference variable. + mutable typar_solution: TType option + + /// A cached TAST type used when this type variable is used as type. + mutable typar_astype: TType + + /// The optional data for the type parameter + mutable typar_opt_data: TyparOptionalData option + } /// The name of the type parameter - member x.Name = x.Id.idText + member x.Name = x.typar_id.idText /// The range of the identifier for the type parameter definition - member x.Range = x.Id.idRange + member x.Range = x.typar_id.idRange /// The identifier for a type parameter definition - member x.Id : Ident = - match typar_id with - | Initial(ident) - | PrettyTyparName(currentIdent = ident) -> ident - - member x.TyparId = typar_id - - member x.Flags = typar_flags - - member x.OptionalData = typar_opt_data + member x.Id = x.typar_id /// The unique stamp of the type parameter - member x.Stamp = typar_stamp + member x.Stamp = x.typar_stamp /// The inferred equivalence for the type inference variable, if any. - member x.Solution = typar_solution + member x.Solution = x.typar_solution /// The inferred constraints for the type inference variable, if any member x.Constraints = - match typar_opt_data with + match x.typar_opt_data with | Some optData -> optData.typar_constraints | _ -> [] /// Indicates if the type variable is compiler generated, i.e. is an implicit type inference variable - member x.IsCompilerGenerated = typar_flags.IsCompilerGenerated + member x.IsCompilerGenerated = x.typar_flags.IsCompilerGenerated /// Indicates if the type variable can be solved or given new constraints. The status of a type variable /// generally always evolves towards being either rigid or solved. - member x.Rigidity = typar_flags.Rigidity + member x.Rigidity = x.typar_flags.Rigidity /// Indicates if a type parameter is needed at runtime and may not be eliminated - member x.DynamicReq = typar_flags.DynamicReq + member x.DynamicReq = x.typar_flags.DynamicReq /// Indicates that whether or not a generic type definition satisfies the equality constraint is dependent on whether this type variable satisfies the equality constraint. - member x.EqualityConditionalOn = typar_flags.EqualityConditionalOn + member x.EqualityConditionalOn = x.typar_flags.EqualityConditionalOn /// Indicates that whether or not a generic type definition satisfies the comparison constraint is dependent on whether this type variable satisfies the comparison constraint. - member x.ComparisonConditionalOn = typar_flags.ComparisonConditionalOn + member x.ComparisonConditionalOn = x.typar_flags.ComparisonConditionalOn /// Indicates if the type variable has a static "head type" requirement, i.e. ^a variables used in FSharp.Core and member constraints. - member x.StaticReq = typar_flags.StaticReq + member x.StaticReq = x.typar_flags.StaticReq /// Indicates if the type inference variable was generated after an error when type checking expressions or patterns - member x.IsFromError = typar_flags.IsFromError + member x.IsFromError = x.typar_flags.IsFromError /// Indicates that whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) - member x.IsCompatFlex = typar_flags.IsCompatFlex + member x.IsCompatFlex = x.typar_flags.IsCompatFlex /// Set whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) - member x.SetIsCompatFlex b = typar_flags <- typar_flags.WithCompatFlex b + member x.SetIsCompatFlex b = x.typar_flags <- x.typar_flags.WithCompatFlex b /// Indicates whether a type variable can be instantiated by types or units-of-measure. - member x.Kind = typar_flags.Kind + member x.Kind = x.typar_flags.Kind /// Indicates whether a type variable is erased in compiled .NET IL code, i.e. whether it is a unit-of-measure variable member x.IsErased = match x.Kind with TyparKind.Type -> false | _ -> true /// The declared attributes of the type parameter. Empty for type inference variables and parameters from .NET. member x.Attribs = - match typar_opt_data with + match x.typar_opt_data with | Some optData -> optData.typar_attribs | _ -> [] /// Set the attributes on the type parameter member x.SetAttribs attribs = - match attribs, typar_opt_data with + match attribs, x.typar_opt_data with | [], None -> () | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = [] } when doc.IsEmpty -> - typar_opt_data <- None + x.typar_opt_data <- None | _, Some optData -> optData.typar_attribs <- attribs - | _ -> typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } + | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } /// Get the XML documetnation for the type parameter member x.XmlDoc = - match typar_opt_data with + match x.typar_opt_data with | Some optData -> optData.typar_xmldoc | _ -> XmlDoc.Empty /// Get the IL name of the type parameter member x.ILName = - match typar_opt_data with + match x.typar_opt_data with | Some optData -> optData.typar_il_name | _ -> None /// Set the IL name of the type parameter member x.SetILName il_name = - match typar_opt_data with + match x.typar_opt_data with | Some optData -> optData.typar_il_name <- il_name - | _ -> typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = [] } + | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = [] } /// Indicates the display name of a type variable member x.DisplayName = if x.Name = "?" then "?"+string x.Stamp else x.Name /// Adjusts the constraints associated with a type variable member x.SetConstraints cs = - match cs, typar_opt_data with + match cs, x.typar_opt_data with | [], None -> () | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [] } when doc.IsEmpty -> - typar_opt_data <- None + x.typar_opt_data <- None | _, Some optData -> optData.typar_constraints <- cs - | _ -> typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = [] } + | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = [] } /// Creates a type variable that contains empty data, and is not yet linked. Only used during unpickling of F# metadata. - static member NewUnlinked() : Typar = - Typar( - TyparId.Initial(Unchecked.defaultof<_>), - Unchecked.defaultof<_>, - -1L, - Unchecked.defaultof<_>, - Unchecked.defaultof<_>, - Unchecked.defaultof<_> - ) + static member NewUnlinked() : Typar = + { typar_id = Unchecked.defaultof<_> + typar_flags = Unchecked.defaultof<_> + typar_stamp = -1L + typar_solution = Unchecked.defaultof<_> + typar_astype = Unchecked.defaultof<_> + typar_opt_data = Unchecked.defaultof<_> } /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. static member New (data: TyparData) : Typar = data /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. - member x.Link (tg: TyparData) = - typar_id <- tg.TyparId - typar_flags <- tg.Flags - typar_stamp <- tg.Stamp - typar_solution <- tg.Solution - match tg.OptionalData with + member x.Link (tg: TyparData) = + x.typar_id <- tg.typar_id + x.typar_flags <- tg.typar_flags + x.typar_stamp <- tg.typar_stamp + x.typar_solution <- tg.typar_solution + match tg.typar_opt_data with | Some tg -> let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs } - typar_opt_data <- Some optData + x.typar_opt_data <- Some optData | None -> () /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. member x.AsType = - let ty = typar_astype + let ty = x.typar_astype match box ty with | null -> let ty2 = TType_var (x, 0uy) - typar_astype <- ty2 + x.typar_astype <- ty2 ty2 | _ -> ty /// Indicates if a type variable has been linked. Only used during unpickling of F# metadata. - member x.IsLinked = typar_stamp <> -1L + member x.IsLinked = x.typar_stamp <> -1L /// Indicates if a type variable has been solved. member x.IsSolved = @@ -2307,53 +2285,36 @@ type Typar | _ -> true /// Sets the identifier associated with a type variable - member x.SetIdent id = - // BindTypars from PostInferenceChecks can be called by multiple threads (when graph based type-checking is enabled). - lock lockObj (fun () -> - match typar_id, id with - | TyparId.PrettyTyparName(originalIdent, oldIndex, _), - TyparId.PrettyTyparName(_, newIndex, newIdent) when newIndex < oldIndex -> - // Overwrite the ident when a file with a lower index tries to use a pretty name. - // This is to match the behaviour of sequential type-checking in graph based type-checking. - typar_id <- TyparId.PrettyTyparName(originalIdent, newIndex, newIdent) - | TyparId.PrettyTyparName _, TyparId.PrettyTyparName _ -> () - | _ -> - typar_id <- id - ) - - member _.SetSolution solution = - typar_solution <- Some solution - - member _.ClearSolution() = typar_solution <- None - + member x.SetIdent id = x.typar_id <- id + /// Sets the rigidity of a type variable member x.SetRigidity b = - let flags = typar_flags - typar_flags <- TyparFlags(flags.Kind, b, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) + let flags = x.typar_flags + x.typar_flags <- TyparFlags(flags.Kind, b, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) /// Sets whether a type variable is compiler generated member x.SetCompilerGenerated b = - let flags = typar_flags - typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, b, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) + let flags = x.typar_flags + x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, b, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) /// Sets whether a type variable has a static requirement member x.SetStaticReq b = - typar_flags <- typar_flags.WithStaticReq(b) + x.typar_flags <- x.typar_flags.WithStaticReq(b) /// Sets whether a type variable is required at runtime member x.SetDynamicReq b = - let flags = typar_flags - typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, b, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) + let flags = x.typar_flags + x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, b, flags.EqualityConditionalOn, flags.ComparisonConditionalOn) /// Sets whether the equality constraint of a type definition depends on this type variable member x.SetEqualityDependsOn b = - let flags = typar_flags - typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, b, flags.ComparisonConditionalOn) + let flags = x.typar_flags + x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, b, flags.ComparisonConditionalOn) /// Sets whether the comparison constraint of a type definition depends on this type variable member x.SetComparisonDependsOn b = - let flags = typar_flags - typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, b) + let flags = x.typar_flags + x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, b) [] member x.DebugText = x.ToString() @@ -5865,18 +5826,16 @@ type Construct() = /// Create a new type parameter node static member NewTypar (kind, rigid, SynTypar(id, staticReq, isCompGen), isFromError, dynamicReq, attribs, eqDep, compDep) = - Typar.New ( - Typar( - TyparId.Initial id, - TyparFlags(kind, rigid, isFromError, isCompGen, staticReq, dynamicReq, eqDep, compDep), - newStamp(), - None, - Unchecked.defaultof<_>, + Typar.New + { typar_id = id + typar_stamp = newStamp() + typar_flags= TyparFlags(kind, rigid, isFromError, isCompGen, staticReq, dynamicReq, eqDep, compDep) + typar_solution = None + typar_astype = Unchecked.defaultof<_> + typar_opt_data = match attribs with | [] -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } - ) - ) + | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } } /// Create a new type parameter node for a declared type parameter static member NewRigidTypar nm m = diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 69125427a29..8cee5e349f7 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -1442,37 +1442,31 @@ type TyparOptionalData = type TyparData = Typar -/// Wrapper around Ident to deal with various Typar.Id updates. -[] -type TyparId = - /// Used for new creations, when unpickling or when we use the same id in the signature during conformance. - | Initial of Ident - /// PrettyTyparName - | PrettyTyparName of originalIdent: Ident * currentIndex: int * currentIdent: Ident - -/// A declared generic type/measure parameter, or a type/measure inference variable. +/// A declared generic type/measure parameter, or a type/measure inference variable. [] type Typar = - /// - /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation. - /// The identifier for the type parameter. - /// - /// The flag data for the type parameter. - /// - /// The unique stamp of the type parameter - /// MUTABILITY: for linking when unpickling - /// - /// An inferred equivalence for a type inference variable. - /// A cached TAST type used when this type variable is used as type. - /// The optional data for the type parameter. - new: - typar_id: TyparId * - typar_flags: TyparFlags * - typar_stamp: Stamp * - typar_solution: TType option * - typar_astype: TType * - typar_opt_data: TyparOptionalData option -> - Typar + { + + /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation + /// The identifier for the type parameter + mutable typar_id: Syntax.Ident + + /// The flag data for the type parameter + mutable typar_flags: TyparFlags + + /// The unique stamp of the type parameter + /// MUTABILITY: for linking when unpickling + mutable typar_stamp: Stamp + + /// An inferred equivalence for a type inference variable. + mutable typar_solution: TType option + + /// A cached TAST type used when this type variable is used as type. + mutable typar_astype: TType + + /// The optional data for the type parameter + mutable typar_opt_data: TyparOptionalData option + } /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. static member New: data: TyparData -> Typar @@ -1505,7 +1499,7 @@ type Typar = member SetILName: il_name: string option -> unit /// Sets the identifier associated with a type variable - member SetIdent: id: TyparId -> unit + member SetIdent: id: Syntax.Ident -> unit /// Set whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) member SetIsCompatFlex: b: bool -> unit @@ -1516,10 +1510,6 @@ type Typar = /// Sets whether a type variable has a static requirement member SetStaticReq: b: Syntax.TyparStaticReq -> unit - member SetSolution: solution: TType -> unit - - member ClearSolution: unit -> unit - override ToString: unit -> string /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. @@ -1552,12 +1542,6 @@ type Typar = /// The identifier for a type parameter definition member Id: Syntax.Ident - member TyparId: TyparId - - member Flags: TyparFlags - - member OptionalData: TyparOptionalData option - /// Indicates that whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) member IsCompatFlex: bool diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index a2725265292..511a4cc44f2 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -197,15 +197,17 @@ let mkTyparTy (tp: Typar) = // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. let copyTypar clearStaticReq (tp: Typar) = - let optData = tp.OptionalData |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs }) - let flags = if clearStaticReq then tp.Flags.WithStaticReq(TyparStaticReq.None) else tp.Flags - Typar.New ( - Typar(tp.TyparId, flags, newStamp(), tp.Solution, Unchecked.defaultof<_>, - // Be careful to clone the mutable optional data too - optData) - ) - -let copyTypars clearStaticReq (tps: Typars) = List.map (copyTypar clearStaticReq) tps + let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs }) + let flags = if clearStaticReq then tp.typar_flags.WithStaticReq(TyparStaticReq.None) else tp.typar_flags + Typar.New { typar_id = tp.typar_id + typar_flags = flags + typar_stamp = newStamp() + typar_solution = tp.typar_solution + typar_astype = Unchecked.defaultof<_> + // Be careful to clone the mutable optional data too + typar_opt_data = optData } + +let copyTypars clearStaticReq tps = List.map (copyTypar clearStaticReq) tps //-------------------------------------------------------------------------- // Inference variables @@ -220,7 +222,8 @@ let tryShortcutSolvedUnitPar canShortcut (r: Typar) = | Measure.Var r2 -> match r2.Solution with | None -> () - | Some soln -> r.SetSolution soln + | Some _ as soln -> + r.typar_solution <- soln | _ -> () unt | _ -> @@ -245,7 +248,8 @@ let rec stripTyparEqnsAux canShortcut ty = | TType_var (r2, _) when r2.Constraints.IsEmpty -> match r2.Solution with | None -> () - | Some soln2 -> r.SetSolution soln2 + | Some _ as soln2 -> + r.typar_solution <- soln2 | _ -> () stripTyparEqnsAux canShortcut soln | None -> diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index deb35e0d5ba..44dd905dd91 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -155,7 +155,7 @@ let mkTyparInst (typars: Typars) tyargs = (List.zip typars tyargs: TyparInstantiation) let generalizeTypar tp = mkTyparTy tp -let generalizeTypars (tps: Typars) = List.map generalizeTypar tps +let generalizeTypars tps = List.map generalizeTypar tps let rec remapTypeAux (tyenv: Remap) (ty: TType) = let ty = stripTyparEqns ty @@ -567,7 +567,7 @@ let tryNormalizeMeasureInType g ty = | TType_measure (Measure.Var v) -> match v.Solution with | Some (TType_measure ms) -> - v.SetSolution(TType_measure (normalizeMeasure g ms)) + v.typar_solution <- Some (TType_measure (normalizeMeasure g ms)) ty | _ -> ty | _ -> ty @@ -938,10 +938,10 @@ type TypeEquivEnv with member aenv.BindTyparsToTypes tps1 tys2 = { aenv with EquivTypars = (tps1, tys2, aenv.EquivTypars) |||> List.foldBack2 (fun tp ty tpmap -> tpmap.Add(tp, ty)) } - member aenv.BindEquivTypars (tps1: Typars) (tps2: Typars) = + member aenv.BindEquivTypars tps1 tps2 = aenv.BindTyparsToTypes tps1 (List.map mkTyparTy tps2) - static member FromTyparInst (tpinst: TyparInstantiation) = + static member FromTyparInst tpinst = let tps, tys = List.unzip tpinst TypeEquivEnv.Empty.BindTyparsToTypes tps tys @@ -2324,7 +2324,7 @@ and accFreeInVal opts (v: Val) acc = accFreeInType opts v.val_type acc let freeInTypes opts tys = accFreeInTypes opts tys emptyFreeTyvars let freeInVal opts v = accFreeInVal opts v emptyFreeTyvars let freeInTyparConstraints opts v = accFreeInTyparConstraints opts v emptyFreeTyvars -let accFreeInTypars opts (tps: Typars) acc = List.foldBack (accFreeTyparRef opts) tps acc +let accFreeInTypars opts tps acc = List.foldBack (accFreeTyparRef opts) tps acc let rec addFreeInModuleTy (mtyp: ModuleOrNamespaceType) acc = QueueList.foldBack (typeOfVal >> accFreeInType CollectAllNoCaching) mtyp.AllValsAndMembers @@ -2791,10 +2791,8 @@ module PrettyTypes = // Finally, we skip any names already in use let NeedsPrettyTyparName (tp: Typar) = tp.IsCompilerGenerated && - tp.ILName.IsNone && - match tp.TyparId with - | TyparId.PrettyTyparName _ -> true - | _ -> tp.Name = unassignedTyparName + tp.ILName.IsNone && + (tp.typar_id.idText = unassignedTyparName) let PrettyTyparNames pred alreadyInUse tps = let rec choose (tps: Typar list) (typeIndex, measureIndex) acc = @@ -8705,7 +8703,7 @@ and tyargsEnc g (gtpsType, gtpsMethod) args = | [a] when (match (stripTyEqns g a) with TType_measure _ -> true | _ -> false) -> "" // float should appear as just "float" in the generated .XML xmldoc file | _ -> angleEnc (commaEncs (List.map (typeEnc g (gtpsType, gtpsMethod)) args)) -let XmlDocArgsEnc g (gtpsType: Typars, gtpsMethod: Typars) argTys = +let XmlDocArgsEnc g (gtpsType, gtpsMethod) argTys = if isNil argTys then "" else "(" + String.concat "," (List.map (typeEnc g (gtpsType, gtpsMethod)) argTys) + ")" diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index bacd5dffdc2..818d36ecc9c 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1596,7 +1596,7 @@ let p_tyar_spec_data (x: Typar) st = p_int64 p_tyar_constraints p_xmldoc - (x.Id, x.Attribs, int64 x.Flags.PickledBits, x.Constraints, x.XmlDoc) st + (x.typar_id, x.Attribs, int64 x.typar_flags.PickledBits, x.Constraints, x.XmlDoc) st let p_tyar_spec (x: Typar) st = //Disabled, workaround for bug 2721: if x.Rigidity <> TyparRigidity.Rigid then warning(Error(sprintf "p_tyar_spec: typar#%d is not rigid" x.Stamp, x.Range)) @@ -1607,16 +1607,15 @@ let p_tyar_specs = (p_list p_tyar_spec) let u_tyar_spec_data st = let a, c, d, e, g = u_tup5 u_ident u_attribs u_int64 u_tyar_constraints u_xmldoc st - Typar( - TyparId.Initial a, - TyparFlags(int32 d), - newStamp(), - None, - Unchecked.defaultof<_>, + { typar_id=a + typar_stamp=newStamp() + typar_flags=TyparFlags(int32 d) + typar_solution=None + typar_astype= Unchecked.defaultof<_> + typar_opt_data= match g, e, c with | doc, [], [] when doc.IsEmpty -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c } - ) + | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c } } let u_tyar_spec st = u_osgn_decl st.itypars u_tyar_spec_data st From 8731fde2fbf3455ba1fb22dad139fcdf7d483b32 Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 21 Mar 2023 17:48:28 +0100 Subject: [PATCH 11/14] Don't duplicate typars in serialization. --- src/Compiler/TypedTree/TypeTreeSerialization.fs | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) diff --git a/src/Compiler/TypedTree/TypeTreeSerialization.fs b/src/Compiler/TypedTree/TypeTreeSerialization.fs index ec8f1e65f7c..d3ce682af23 100644 --- a/src/Compiler/TypedTree/TypeTreeSerialization.fs +++ b/src/Compiler/TypedTree/TypeTreeSerialization.fs @@ -58,23 +58,10 @@ and visitVal (v: Val) : TypedTreeNode = match v.ValReprInfo with | None -> () - | Some (ValReprInfo (typars, args, result)) -> + | Some (ValReprInfo (_, args, result)) -> yield! args |> Seq.collect id |> Seq.map visitArgReprInfo - yield visitArgReprInfo result - yield! - typars - |> List.map (fun (TyparReprInfo (ident, _kind)) -> - { - Name = ident.idText - Kind = "typar" - Children = [] - Flags = None - Range = Some ident.idRange - CompilationPath = None - }) - yield! v.Typars |> Seq.map (fun typar -> @@ -82,7 +69,7 @@ and visitVal (v: Val) : TypedTreeNode = Name = typar.Name Kind = "typar" Children = [] - Flags = Some typar.Flags.PickledBits + Flags = Some typar.typar_flags.PickledBits Range = Some typar.Range CompilationPath = None }) From 53f01e542d38ef482027d72d99edf162ca7ff1b4 Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 21 Mar 2023 17:49:00 +0100 Subject: [PATCH 12/14] Reapply typar naming to signature data. --- src/Compiler/Driver/ParseAndCheckInputs.fs | 26 +++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index b011cc1971b..0e65c849cf3 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1779,11 +1779,33 @@ let CheckMultipleInputsUsingGraphMode partialResults, tcState) +/// The Typars of a Val can be determined by the call site. +/// As the type-checking can now happen in parallel, the naming is no longer deterministic. +/// Overall this only seems to affect the pickled signature data later on. +/// But in order to regain deterministic names, we re-do the pretty naming for all typars of Vals. +let rec updatePrettyNamesForTyparsInEntity (entity: Entity) = + for e in entity.ModuleOrNamespaceType.AllEntities do + updatePrettyNamesForTyparsInEntity e + + for v in entity.ModuleOrNamespaceType.AllValsAndMembers do + updatePrettyNamesForTyparsInVal v + +and updatePrettyNamesForTyparsInVal (v: Val) = + if not (List.isEmpty v.Typars) then + // Reset typar name to ? + for typar in v.Typars do + typar.typar_id <- Ident(unassignedTyparName, typar.typar_id.idRange) + + let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) List.empty v.Typars + + (v.Typars, nms) + ||> List.iter2 (fun tp nm -> tp.typar_id <- ident (nm, tp.Range)) + let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs) = // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions let results, tcState = match tcConfig.typeCheckingConfig.Mode with - | TypeCheckingMode.Graph when (not tcConfig.isInteractive && not tcConfig.deterministic) -> + | TypeCheckingMode.Graph when (not tcConfig.isInteractive) -> CheckMultipleInputsUsingGraphMode( ctok, checkForErrors, @@ -1803,5 +1825,7 @@ let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tc let tcState, declaredImpls, ccuContents = CheckClosedInputSetFinish(implFiles, tcState) + updatePrettyNamesForTyparsInEntity ccuContents + tcState.Ccu.Deref.Contents <- ccuContents tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile From 4862b1cc8ff22af4a2082637daa122c01306ffe3 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 22 Mar 2023 10:56:24 +0100 Subject: [PATCH 13/14] Only update compiler generated typars. --- src/Compiler/Driver/ParseAndCheckInputs.fs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 0e65c849cf3..0e84bcd338c 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1794,7 +1794,8 @@ and updatePrettyNamesForTyparsInVal (v: Val) = if not (List.isEmpty v.Typars) then // Reset typar name to ? for typar in v.Typars do - typar.typar_id <- Ident(unassignedTyparName, typar.typar_id.idRange) + if typar.IsCompilerGenerated && typar.ILName.IsNone then + typar.typar_id <- Ident(unassignedTyparName, typar.typar_id.idRange) let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) List.empty v.Typars From 55595fbec07e5af6bae3b17c4947c4f73afc9d49 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 23 Mar 2023 11:26:44 +0100 Subject: [PATCH 14/14] Update Typar names from declaredImpls. --- src/Compiler/Driver/ParseAndCheckInputs.fs | 58 +++++++++++++++------- 1 file changed, 39 insertions(+), 19 deletions(-) diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 0e84bcd338c..d9a402a57f9 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1783,24 +1783,41 @@ let CheckMultipleInputsUsingGraphMode /// As the type-checking can now happen in parallel, the naming is no longer deterministic. /// Overall this only seems to affect the pickled signature data later on. /// But in order to regain deterministic names, we re-do the pretty naming for all typars of Vals. -let rec updatePrettyNamesForTyparsInEntity (entity: Entity) = - for e in entity.ModuleOrNamespaceType.AllEntities do - updatePrettyNamesForTyparsInEntity e - - for v in entity.ModuleOrNamespaceType.AllValsAndMembers do - updatePrettyNamesForTyparsInVal v - -and updatePrettyNamesForTyparsInVal (v: Val) = - if not (List.isEmpty v.Typars) then - // Reset typar name to ? - for typar in v.Typars do - if typar.IsCompilerGenerated && typar.ILName.IsNone then - typar.typar_id <- Ident(unassignedTyparName, typar.typar_id.idRange) - - let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) List.empty v.Typars - - (v.Typars, nms) - ||> List.iter2 (fun tp nm -> tp.typar_id <- ident (nm, tp.Range)) +module UpdatePrettyNames = + let rec updateEntity (entity: Entity) = + for e in entity.ModuleOrNamespaceType.AllEntities do + updateEntity e + + for v in entity.ModuleOrNamespaceType.AllValsAndMembers do + updateVal v + + and private updateVal (v: Val) = + if not (List.isEmpty v.Typars) then + // Reset typar name to ? + for typar in v.Typars do + if typar.IsCompilerGenerated && typar.ILName.IsNone then + typar.typar_id <- Ident(unassignedTyparName, typar.typar_id.idRange) + + let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) List.empty v.Typars + + (v.Typars, nms) + ||> List.iter2 (fun tp nm -> tp.typar_id <- ident (nm, tp.Range)) + + and updateModuleOrNamespaceContent (contents: ModuleOrNamespaceContents) = + match contents with + | ModuleOrNamespaceContents.TMDefs defs -> + for def in defs do + updateModuleOrNamespaceContent def + | ModuleOrNamespaceContents.TMDefDo _ + | ModuleOrNamespaceContents.TMDefOpens _ -> () + | ModuleOrNamespaceContents.TMDefLet (binding, _) -> updateBinding binding + | ModuleOrNamespaceContents.TMDefRec (bindings = bindings) -> + for binding in bindings do + match binding with + | ModuleOrNamespaceBinding.Binding binding -> updateBinding binding + | ModuleOrNamespaceBinding.Module (_, moduleOrNamespaceContents) -> updateModuleOrNamespaceContent moduleOrNamespaceContents + + and private updateBinding (binding: Binding) = updateVal binding.Var let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs) = // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions @@ -1826,7 +1843,10 @@ let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tc let tcState, declaredImpls, ccuContents = CheckClosedInputSetFinish(implFiles, tcState) - updatePrettyNamesForTyparsInEntity ccuContents + for declImpl in declaredImpls do + UpdatePrettyNames.updateModuleOrNamespaceContent declImpl.Contents + + UpdatePrettyNames.updateEntity ccuContents tcState.Ccu.Deref.Contents <- ccuContents tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile