diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index ef30acc7efc..81db7f54c59 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -353,6 +353,9 @@ TypedAST/QuotationPickler.fs + + TypedAST/CompilerGlobalState.fs + TypedAST/tast.fs diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 237b6ae70dd..d95bf2d0706 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -4639,13 +4639,13 @@ type TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAssemblyResolu match scoref with | ILScopeRef.Assembly aref -> Some aref | ILScopeRef.Local | ILScopeRef.Module _ -> error(InternalError("not ILScopeRef.Assembly", rangeStartup))) - fslibCcuInfo.FSharpViewOfMetadata - + fslibCcuInfo.FSharpViewOfMetadata + // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals - let tcGlobals = TcGlobals(tcConfig.compilingFslib, ilGlobals, fslibCcu, - tcConfig.implicitIncludeDir, tcConfig.mlCompatibility, - tcConfig.isInteractive, tryFindSysTypeCcu, tcConfig.emitDebugInfoInQuotations, - tcConfig.noDebugData, tcConfig.pathMap) + let tcGlobals = TcGlobals(tcConfig.compilingFslib, ilGlobals, fslibCcu, + tcConfig.implicitIncludeDir, tcConfig.mlCompatibility, + tcConfig.isInteractive, tryFindSysTypeCcu, tcConfig.emitDebugInfoInQuotations, + tcConfig.noDebugData, tcConfig.pathMap) #if DEBUG // the global_g reference cell is used only for debug printing diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 94d9bf53713..3d08610670a 100644 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -708,7 +708,7 @@ val GetInitialTcEnv: assemblyName: string * range * TcConfig * TcImports * TcGlo [] /// Represents the incremental type checking state for a set of inputs type TcState = - member NiceNameGenerator: Ast.NiceNameGenerator + member NiceNameGenerator: NiceNameGenerator /// The CcuThunk for the current assembly being checked member Ccu: CcuThunk @@ -729,7 +729,7 @@ type TcState = /// Get the initial type checking state for a set of inputs val GetInitialTcState: - range * string * TcConfig * TcGlobals * TcImports * Ast.NiceNameGenerator * TcEnv -> TcState + range * string * TcConfig * TcGlobals * TcImports * NiceNameGenerator * TcEnv -> TcState /// Check one input, returned as an Eventually computation val TypeCheckOneInputEventually : diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index 3a30ed50077..0c385cc3670 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -1572,17 +1572,17 @@ let ApplyCommandLineArgs(tcConfigB: TcConfigBuilder, sourceFiles: string list, c //---------------------------------------------------------------------------- let showTermFileCount = ref 0 -let PrintWholeAssemblyImplementation (tcConfig:TcConfig) outfile header expr = +let PrintWholeAssemblyImplementation g (tcConfig:TcConfig) outfile header expr = if tcConfig.showTerms then if tcConfig.writeTermsToFiles then let filename = outfile + ".terms" let n = !showTermFileCount showTermFileCount := n+1 use f = System.IO.File.CreateText (filename + "-" + string n + "-" + header) - Layout.outL f (Layout.squashTo 192 (DebugPrint.implFilesL expr)) + Layout.outL f (Layout.squashTo 192 (DebugPrint.implFilesL g expr)) else dprintf "\n------------------\nshowTerm: %s:\n" header - Layout.outL stderr (Layout.squashTo 192 (DebugPrint.implFilesL expr)) + Layout.outL stderr (Layout.squashTo 192 (DebugPrint.implFilesL g expr)) dprintf "\n------------------\n" //---------------------------------------------------------------------------- @@ -1680,13 +1680,13 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM // Always optimize once - the results of this step give the x-module optimization // info. Subsequent optimization steps choose representations etc. which we don't // want to save in the x-module info (i.e. x-module info is currently "high level"). - PrintWholeAssemblyImplementation tcConfig outfile "pass-start" implFiles + PrintWholeAssemblyImplementation tcGlobals tcConfig outfile "pass-start" implFiles #if DEBUG if tcConfig.showOptimizationData then - dprintf "Expression prior to optimization:\n%s\n" (Layout.showL (Layout.squashTo 192 (DebugPrint.implFilesL implFiles))) + dprintf "Expression prior to optimization:\n%s\n" (Layout.showL (Layout.squashTo 192 (DebugPrint.implFilesL tcGlobals implFiles))) if tcConfig.showOptimizationData then - dprintf "CCU prior to optimization:\n%s\n" (Layout.showL (Layout.squashTo 192 (DebugPrint.entityL ccu.Contents))) + dprintf "CCU prior to optimization:\n%s\n" (Layout.showL (Layout.squashTo 192 (DebugPrint.entityL tcGlobals ccu.Contents))) #endif let optEnv0 = optEnv @@ -1768,12 +1768,10 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFiles, implFileOptDatas = List.unzip results let assemblyOptData = Optimizer.UnionOptimizationInfos implFileOptDatas let tassembly = TypedAssemblyAfterOptimization implFiles - PrintWholeAssemblyImplementation tcConfig outfile "pass-end" (List.map fst implFiles) + PrintWholeAssemblyImplementation tcGlobals tcConfig outfile "pass-end" (List.map fst implFiles) ReportTime tcConfig ("Ending Optimizations") - tassembly, assemblyOptData, optEnvFirstLoop - //---------------------------------------------------------------------------- // ILX generation //---------------------------------------------------------------------------- diff --git a/src/fsharp/CompilerGlobalState.fs b/src/fsharp/CompilerGlobalState.fs new file mode 100644 index 00000000000..1e857e7cade --- /dev/null +++ b/src/fsharp/CompilerGlobalState.fs @@ -0,0 +1,96 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +/// Defines the global environment for all type checking. + +namespace FSharp.Compiler + +open System.Collections.Generic +open FSharp.Compiler.AbstractIL +open FSharp.Compiler.Range +open FSharp.Compiler.PrettyNaming + + +/// Generates compiler-generated names. Each name generated also includes the StartLine number of the range passed in +/// at the point of first generation. +/// +/// This type may be accessed concurrently, though in practice it is only used from the compilation thread. +/// It is made concurrency-safe since a global instance of the type is allocated in tast.fs, and it is good +/// policy to make all globally-allocated objects concurrency safe in case future versions of the compiler +/// are used to host multiple concurrent instances of compilation. +type NiceNameGenerator() = + + let lockObj = obj() + let basicNameCounts = new Dictionary(100) + + member x.FreshCompilerGeneratedName (name, m: range) = + lock lockObj (fun () -> + let basicName = GetBasicNameOfPossibleCompilerGeneratedName name + let n = + match basicNameCounts.TryGetValue basicName with + | true, count -> count + | _ -> 0 + let nm = CompilerGeneratedNameSuffix basicName (string m.StartLine + (match n with 0 -> "" | n -> "-" + string n)) + basicNameCounts.[basicName] <- n + 1 + nm) + + member x.Reset () = + lock lockObj (fun () -> + basicNameCounts.Clear() + ) + +/// Generates compiler-generated names marked up with a source code location, but if given the same unique value then +/// return precisely the same name. Each name generated also includes the StartLine number of the range passed in +/// at the point of first generation. +/// +/// This type may be accessed concurrently, though in practice it is only used from the compilation thread. +/// It is made concurrency-safe since a global instance of the type is allocated in tast.fs. +type StableNiceNameGenerator() = + + let lockObj = obj() + + let names = new Dictionary<(string * int64), string>(100) + let basicNameCounts = new Dictionary(100) + + member x.GetUniqueCompilerGeneratedName (name, m: range, uniq) = + lock lockObj (fun () -> + let basicName = GetBasicNameOfPossibleCompilerGeneratedName name + let key = basicName, uniq + match names.TryGetValue key with + | true, nm -> nm + | _ -> + let n = + match basicNameCounts.TryGetValue basicName with + | true, c -> c + | _ -> 0 + let nm = CompilerGeneratedNameSuffix basicName (string m.StartLine + (match n with 0 -> "" | n -> "-" + string n)) + names.[key] <- nm + basicNameCounts.[basicName] <- n + 1 + nm + ) + + member x.Reset () = + lock lockObj (fun () -> + basicNameCounts.Clear() + names.Clear() + ) + +type internal CompilerGlobalState () = + /// A global generator of compiler generated names + // ++GLOBAL MUTABLE STATE (concurrency safe by locking inside NiceNameGenerator) + let globalNng = NiceNameGenerator() + + + /// A global generator of stable compiler generated names + // MUTABLE STATE (concurrency safe by locking inside StableNiceNameGenerator) + let globalStableNameGenerator = StableNiceNameGenerator () + + /// A name generator used by IlxGen for static fields, some generated arguments and other things. + /// REVIEW: this will mean the hosted compiler service is not deterministic. We should at least create a new one + /// of these for each compilation. + let ilxgenGlobalNng = NiceNameGenerator () + + member __.NiceNameGenerator = globalNng + + member __.StableNameGenerator = globalStableNameGenerator + + member __.IlxGenNiceNameGenerator = ilxgenGlobalNng diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 9af6d4f32ac..8ae41acb317 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -484,8 +484,11 @@ let mkTransform g (f: Val) m tps x1Ntys rty (callPattern, tyfringes: (TType list let tys1r = List.collect fst tyfringes (* types for collapsed initial r args *) let tysrN = List.drop tyfringes.Length x1Ntys (* types for remaining args *) let argtys = tys1r @ tysrN - let fCty = mkLambdaTy tps argtys rty - let transformedVal = mkLocalVal f.Range (globalNng.FreshCompilerGeneratedName (f.LogicalName, f.Range)) fCty topValInfo + let fCty = mkLambdaTy tps argtys rty + let transformedVal = + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + mkLocalVal f.Range (g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName (f.LogicalName, f.Range)) fCty topValInfo { transformCallPattern = callPattern transformedFormals = transformedFormals transformedVal = transformedVal } diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index b770a3cb615..578d12460b8 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -366,6 +366,9 @@ TypedAST\QuotationPickler.fs + + TypedAST\CompilerGlobalState.fs + TypedAST\tast.fs diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 09750c4f32d..c188b548073 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -101,11 +101,6 @@ let ChooseFreeVarNames takenNames ts = let ts, _names = List.mapFold chooseName names tns ts -/// +++GLOBAL STATE: a name generator used by IlxGen for static fields, some generated arguments and other things. -/// REVIEW: this will mean the hosted compiler service is not deterministic. We should at least create a new one -/// of these for each compilation. -let ilxgenGlobalNng = NiceNameGenerator () - /// We can't tailcall to methods taking byrefs. This helper helps search for them let IsILTypeByref = function ILType.Byref _ -> true | _ -> false @@ -649,11 +644,14 @@ and GenTypePermitVoidAux amap m tyenv ty = GenTypeAux amap m tyenv VoidOK PtrTyp // - For interactive code, we always place fields in their type/module with an accurate name let GenFieldSpecForStaticField (isInteractive, g, ilContainerTy, vspec: Val, nm, m, cloc, ilTy) = if isInteractive || HasFSharpAttribute g g.attrib_LiteralAttribute vspec.Attribs then - let fieldName = vspec.CompiledName + let fieldName = vspec.CompiledName g.CompilerGlobalState let fieldName = if isInteractive then CompilerGeneratedName fieldName else fieldName mkILFieldSpecInTy (ilContainerTy, fieldName, ilTy) else - let fieldName = ilxgenGlobalNng.FreshCompilerGeneratedName (nm, m) + let fieldName = + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName (nm, m) let ilFieldContainerTy = mkILTyForCompLoc (CompLocForInitClass cloc) mkILFieldSpecInTy (ilFieldContainerTy, fieldName, ilTy) @@ -884,16 +882,16 @@ let AddStorageForLocalVals g vals eenv = List.foldBack (fun (v, s) acc -> AddSto // Lookup eenv //-------------------------------------------------------------------------- -let StorageForVal m v eenv = +let StorageForVal g m v eenv = let v = try eenv.valsInScope.[v] with :? KeyNotFoundException -> assert false - errorR(Error(FSComp.SR.ilUndefinedValue(showL(valAtBindL v)), m)) + errorR(Error(FSComp.SR.ilUndefinedValue(showL(valAtBindL g v)), m)) notlazy (Arg 668(* random value for post-hoc diagnostic analysis on generated tree *) ) v.Force() -let StorageForValRef m (v: ValRef) eenv = StorageForVal m v.Deref eenv +let StorageForValRef g m (v: ValRef) eenv = StorageForVal g m v.Deref eenv let IsValRefIsDllImport g (vref: ValRef) = vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute @@ -948,15 +946,15 @@ let GetMethodSpecForMemberVal amap g (memberInfo: ValMemberInfo) (vref: ValRef) let isSlotSig = memberInfo.MemberFlags.IsDispatchSlot || memberInfo.MemberFlags.IsOverrideOrExplicitImpl let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars isSlotSig methodArgTys let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy mtps) - let mspec = mkILInstanceMethSpecInTy (ilTy, vref.CompiledName, ilMethodArgTys, ilActualRetTy, ilMethodInst) - + let mspec = mkILInstanceMethSpecInTy (ilTy, vref.CompiledName g.CompilerGlobalState, ilMethodArgTys, ilActualRetTy, ilMethodInst) + mspec, ctps, mtps, paramInfos, retInfo, methodArgTys else let methodArgTys, paramInfos = List.unzip flatArgInfos let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars false methodArgTys let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy mtps) - let mspec = mkILStaticMethSpecInTy (ilTy, vref.CompiledName, ilMethodArgTys, ilActualRetTy, ilMethodInst) - + let mspec = mkILStaticMethSpecInTy (ilTy, vref.CompiledName g.CompilerGlobalState , ilMethodArgTys, ilActualRetTy, ilMethodInst) + mspec, ctps, mtps, paramInfos, retInfo, methodArgTys /// Determine how a top-level value is represented, when representing as a field, by computing an ILFieldSpec @@ -979,8 +977,8 @@ let ComputeFieldSpecForVal(optIntraAssemblyInfo: IlxGenIntraAssemblyInfo option, /// Compute the representation information for an F#-declared value (not a member nor a function). /// Mutable and literal static fields must have stable names and live in the "public" location -let ComputeStorageForFSharpValue amap g cloc optIntraAssemblyInfo optShadowLocal isInteractive returnTy (vref: ValRef) m = - let nm = vref.CompiledName +let ComputeStorageForFSharpValue amap (g:TcGlobals) cloc optIntraAssemblyInfo optShadowLocal isInteractive returnTy (vref: ValRef) m = + let nm = vref.CompiledName g.CompilerGlobalState let vspec = vref.Deref let ilTy = GenType amap m TypeReprEnv.Empty returnTy (* TypeReprEnv.Empty ok: not a field in a generic class *) let ilTyForProperty = mkILTyForCompLoc cloc @@ -1000,8 +998,8 @@ let ComputeStorageForFSharpMember amap g topValInfo memberInfo (vref: ValRef) m /// Compute the representation information for an F#-declared function in a module or an F#-decalared extension member. /// Note, there is considerable overlap with ComputeStorageForFSharpMember/GetMethodSpecForMemberVal and these could be /// rationalized. -let ComputeStorageForFSharpFunctionOrFSharpExtensionMember amap g cloc topValInfo (vref: ValRef) m = - let nm = vref.CompiledName +let ComputeStorageForFSharpFunctionOrFSharpExtensionMember amap (g:TcGlobals) cloc topValInfo (vref: ValRef) m = + let nm = vref.CompiledName g.CompilerGlobalState let (tps, curriedArgInfos, returnTy, retInfo) = GetTopValTypeInCompiledForm g topValInfo vref.Type m let tyenvUnderTypars = TypeReprEnv.ForTypars tps let (methodArgTys, paramInfos) = curriedArgInfos |> List.concat |> List.unzip @@ -1039,7 +1037,7 @@ let ComputeStorageForTopVal (amap, g, optIntraAssemblyInfo: IlxGenIntraAssemblyI | Some a -> a let m = vref.Range - let nm = vref.CompiledName + let nm = vref.CompiledName g.CompilerGlobalState if vref.Deref.IsCompiledAsStaticPropertyWithoutField then let nm = "get_"+nm @@ -1537,7 +1535,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu member __.AddReflectedDefinition (vspec: Tast.Val, expr) = // preserve order by storing index of item let n = reflectedDefinitions.Count - reflectedDefinitions.Add(vspec, (vspec.CompiledName, n, expr)) + reflectedDefinitions.Add(vspec, (vspec.CompiledName cenv.g.CompilerGlobalState, n, expr)) member __.ReplaceNameOfReflectedDefinition (vspec, newName) = match reflectedDefinitions.TryGetValue vspec with @@ -2188,7 +2186,7 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = List.forall (isMeasureTy g) tyargs && ( // inline only values that are stored in local variables - match StorageForValRef m vref eenv with + match StorageForValRef g m vref eenv with | ValStorage.Local _ -> true | _ -> false ) -> @@ -2948,7 +2946,7 @@ and GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel = // where f is an F# function value or F# method | Expr.Lambda (_, _, _, _, Expr.App (OptionalCoerce(OptionalTyapp(Expr.Val (vref, _, _))), _, _, _, _), _, _) -> - let storage = StorageForValRef m vref eenv + let storage = StorageForValRef g m vref eenv match storage with | Method (_, _, mspec, _, _, _, _) -> CG.EmitInstr cgbuf (pop 0) (Push [g.iltyp_RuntimeMethodHandle]) (I_ldtoken (ILToken.ILMethod mspec)) @@ -2975,7 +2973,7 @@ and GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel = // Optimize calls to top methods when given "enough" arguments. | Expr.Val (vref, valUseFlags, _), _, _ when - (let storage = StorageForValRef m vref eenv + (let storage = StorageForValRef g m vref eenv match storage with | Method (topValInfo, vref, _, _, _, _, _) -> (let tps, argtys, _, _ = GetTopValTypeInFSharpForm g topValInfo vref.Type m @@ -2983,7 +2981,7 @@ and GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel = argtys.Length <= args.Length) | _ -> false) -> - let storage = StorageForValRef m vref eenv + let storage = StorageForValRef g m vref eenv match storage with | Method (topValInfo, vref, mspec, _, _, _, _) -> let nowArgs, laterArgs = @@ -3059,7 +3057,10 @@ and GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel = // Only save arguments that have effects if Optimizer.ExprHasEffect g laterArg then let ilTy = laterArg |> tyOfExpr g |> GenType cenv.amap m eenv.tyenv - let locName = ilxgenGlobalNng.FreshCompilerGeneratedName ("arg", m), ilTy, false + let locName = + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("arg", m), ilTy, false let loc, _realloc, eenv = AllocLocal cenv cgbuf eenv true locName scopeMarks GenExpr cenv cgbuf eenv SPSuppress laterArg Continue EmitSetLocal cgbuf loc @@ -3222,7 +3223,9 @@ and GenTry cenv cgbuf eenv scopeMarks (e1, m, resty, spTry) = let ilResultTy = GenType cenv.amap m eenvinner.tyenv resty let whereToSave, _realloc, eenvinner = - AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("tryres", m), ilResultTy, false) (startTryMark, endTryMark) + // Ensure that we have an g.CompilerGlobalState + assert(cenv.g.CompilerGlobalState |> Option.isSome) + AllocLocal cenv cgbuf eenvinner true (cenv.g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("tryres", m), ilResultTy, false) (startTryMark, endTryMark) // Generate the body of the try. In the normal case (SequencePointAtTry) we generate a sequence point // both on the 'try' keyword and on the start of the expression in the 'try'. For inlined code and @@ -3267,7 +3270,7 @@ and GenTryCatch cenv cgbuf eenv (e1, vf: Val, ef, vh: Val, eh, m, resty, spTry, let _, eenvinner = AllocLocalVal cenv cgbuf vf eenvinner None (startOfFilter, afterFilter) CG.EmitInstr cgbuf (pop 1) (Push [g.iltyp_Exception]) (I_castclass g.iltyp_Exception) - GenStoreVal cgbuf eenvinner vf.Range vf + GenStoreVal cenv cgbuf eenvinner vf.Range vf // Why SPSuppress? Because we do not emit a sequence point at the start of the List.filter - we've already put one on // the 'with' keyword above @@ -3285,7 +3288,7 @@ and GenTryCatch cenv cgbuf eenv (e1, vf: Val, ef, vh: Val, eh, m, resty, spTry, CG.SetStack cgbuf [g.ilg.typ_Object] let _, eenvinner = AllocLocalVal cenv cgbuf vh eenvinner None (startOfHandler, afterHandler) CG.EmitInstr cgbuf (pop 1) (Push [g.iltyp_Exception]) (I_castclass g.iltyp_Exception) - GenStoreVal cgbuf eenvinner vh.Range vh + GenStoreVal cenv cgbuf eenvinner vh.Range vh GenExpr cenv cgbuf eenvinner SPAlways eh (LeaveHandler (false, whereToSave, afterHandler)) end @@ -3303,7 +3306,7 @@ and GenTryCatch cenv cgbuf eenv (e1, vf: Val, ef, vh: Val, eh, m, resty, spTry, let _, eenvinner = AllocLocalVal cenv cgbuf vh eenvinner None (startOfHandler, afterHandler) CG.EmitInstr cgbuf (pop 1) (Push [g.iltyp_Exception]) (I_castclass g.iltyp_Exception) - GenStoreVal cgbuf eenvinner m vh + GenStoreVal cenv cgbuf eenvinner m vh GenExpr cenv cgbuf eenvinner SPAlways eh (LeaveHandler (false, whereToSave, afterHandler)) end @@ -3386,7 +3389,9 @@ and GenForLoop cenv cgbuf eenv (spFor, v, e1, dir, e2, loopBody, m) sequel = let finishIdx, eenvinner = if isFSharpStyle then - let v, _realloc, eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("endLoop", m), g.ilg.typ_Int32, false) (start, finish) + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + let v, _realloc, eenvinner = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("endLoop", m), g.ilg.typ_Int32, false) (start, finish) v, eenvinner else -1, eenvinner @@ -3397,7 +3402,7 @@ and GenForLoop cenv cgbuf eenv (spFor, v, e1, dir, e2, loopBody, m) sequel = | NoSequencePointAtForLoop -> () GenExpr cenv cgbuf eenv SPSuppress e1 Continue - GenStoreVal cgbuf eenvinner m v + GenStoreVal cenv cgbuf eenvinner m v if isFSharpStyle then GenExpr cenv cgbuf eenvinner SPSuppress e2 Continue EmitSetLocal cgbuf finishIdx @@ -3417,7 +3422,7 @@ and GenForLoop cenv cgbuf eenv (spFor, v, e1, dir, e2, loopBody, m) sequel = CG.EmitInstr cgbuf (pop 0) (Push [g.ilg.typ_Int32]) (mkLdcInt32 1) CG.EmitInstr cgbuf (pop 1) Push0 (if isUp then AI_add else AI_sub) - GenStoreVal cgbuf eenvinner m v + GenStoreVal cenv cgbuf eenvinner m v // .text CG.SetMarkToHere cgbuf test @@ -3780,7 +3785,7 @@ and GenGetAddrOfRefCellField cenv cgbuf eenv (e, ty, m) sequel = and GenGetValAddr cenv cgbuf eenv (v: ValRef, m) sequel = let vspec = v.Deref let ilTy = GenTypeOfVal cenv eenv vspec - let storage = StorageForValRef m v eenv + let storage = StorageForValRef cenv.g m v eenv match storage with | Local (idx, _, None) -> @@ -3842,7 +3847,10 @@ and GenDefaultValue cenv cgbuf eenv (ty, m) = | _ -> let ilTy = GenType cenv.amap m eenv.tyenv ty LocalScope "ilzero" cgbuf (fun scopeMarks -> - let locIdx, realloc, _ = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("default", m), ilTy, false) scopeMarks + let locIdx, realloc, _ = + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + AllocLocal cenv cgbuf eenv true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("default", m), ilTy, false) scopeMarks // "initobj" (Generated by EmitInitLocal) doesn't work on byref types // But ilzero(&ty) only gets generated in the built-in get-address function so // we can just rely on zeroinit of all IL locals. @@ -4316,7 +4324,7 @@ and GenTypeOfVal cenv eenv (v: Val) = and GenFreevar cenv m eenvouter tyenvinner (fv: Val) = let g = cenv.g - match StorageForVal m fv eenvouter with + match StorageForVal cenv.g m fv eenvouter with // Local type functions | Local(_, _, Some _) | Env(_, _, _, Some _) -> g.ilg.typ_Object #if DEBUG @@ -4332,7 +4340,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = let basename = let boundv = eenvouter.letBoundVars |> List.tryFind (fun v -> not v.IsCompilerGenerated) match boundv with - | Some v -> v.CompiledName + | Some v -> v.CompiledName cenv.g.CompilerGlobalState | None -> "clo" // Get a unique stamp for the closure. This must be stable for things that can be part of a let rec. @@ -4348,7 +4356,10 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // FSharp 1.0 bug 3404: System.Reflection doesn't like '.' and '`' in type names let basenameSafeForUseAsTypename = CleanUpGeneratedTypeName basename let suffixmark = expr.Range - let cloName = globalStableNameGenerator.GetUniqueCompilerGeneratedName(basenameSafeForUseAsTypename, suffixmark, uniq) + let cloName = + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + g.CompilerGlobalState.Value.StableNameGenerator.GetUniqueCompilerGeneratedName(basenameSafeForUseAsTypename, suffixmark, uniq) NestedTypeRefForCompLoc eenvouter.cloc cloName // Collect the free variables of the closure @@ -4361,7 +4372,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = cloFreeVarResults.FreeLocals |> Zset.elements |> List.filter (fun fv -> - match StorageForVal m fv eenvouter with + match StorageForVal cenv.g m fv eenvouter with | (StaticField _ | StaticProperty _ | Method _ | Null) -> false | _ -> match selfv with @@ -4406,7 +4417,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = let ilCloFreeVarStorage = (cloFreeVars, ilCloFreeVars) ||> List.mapi2 (fun i v fv -> let localCloInfo = - match StorageForVal m v eenvouter with + match StorageForVal g m v eenvouter with | Local(_, _, localCloInfo) | Env(_, _, _, localCloInfo) -> localCloInfo | _ -> None @@ -4444,7 +4455,7 @@ and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = (List.rev tvacc, List.rev vacc, e, ety) getCallStructure [] [] (expr, returnTy) - let takenNames = vs |> List.map (fun v -> v.CompiledName) + let takenNames = vs |> List.map (fun v -> v.CompiledName g.CompilerGlobalState) // Get the free variables and the information about the closure, add the free variables to the environment let (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, _, cloFreeVars, ilCloTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr @@ -4458,7 +4469,7 @@ and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = let lambdas = (tvs, l) ||> List.foldBack (fun tv sofar -> Lambdas_forall(GenGenericParam cenv eenv tv, sofar)) lambdas, eenv | [], v :: rest -> - let nm = v.CompiledName + let nm = v.CompiledName g.CompilerGlobalState let l, eenv = let eenv = AddStorageForVal g (v, notlazy (Arg ntmargs)) eenv getClosureArgs eenv (ntmargs+1) [] rest @@ -4817,7 +4828,7 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx // However not all targets are currently postponed (we only postpone in debug code), pending further testing of the performance // impact of postponing. (vs, es) ||> List.iter2 (GenBindingRhs cenv cgbuf eenv SPSuppress) - vs |> List.rev |> List.iter (fun v -> GenStoreVal cgbuf eenvAtTarget v.Range v) + vs |> List.rev |> List.iter (fun v -> GenStoreVal cenv cgbuf eenvAtTarget v.Range v) CG.EmitInstr cgbuf (pop 0) Push0 (I_br targetMarkAfterBinds.CodeLabel) targetInfos @@ -5075,7 +5086,7 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = // Fix up recursion for non-toplevel recursive bindings let bindsPossiblyRequiringFixup = allBinds |> List.filter (fun b -> - match (StorageForVal m b.Var eenv) with + match (StorageForVal cenv.g m b.Var eenv) with | StaticProperty _ | Method _ // Note: Recursive data stored in static fields may require fixups e.g. let x = C(x) @@ -5091,7 +5102,7 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = let clo, _, eenvclo = GetIlxClosureInfo cenv m isLocalTypeFunc selfv {eenv with letBoundVars=(mkLocalValRef boundv) :: eenv.letBoundVars} e clo.cloFreeVars |> List.iter (fun fv -> if Zset.contains fv forwardReferenceSet then - match StorageForVal m fv eenvclo with + match StorageForVal cenv.g m fv eenvclo with | Env (_, _, ilField, _) -> fixups := (boundv, fv, (fun () -> GenLetRecFixup cenv cgbuf eenv (clo.cloSpec, access, ilField, exprForVal m fv, m))) :: !fixups | _ -> error (InternalError("GenLetRec: " + fv.LogicalName + " was not in the environment", m)) ) @@ -5175,14 +5186,14 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s // Workaround for .NET and Visual Studio restriction w.r.t debugger type proxys // Mark internal constructors in internal classes as public. let access = - if access = ILMemberAccess.Assembly && vspec.IsConstructor && IsHiddenTycon eenv.sigToImplRemapInfo vspec.MemberApparentEntity.Deref then + if access = ILMemberAccess.Assembly && vspec.IsConstructor && IsHiddenTycon g eenv.sigToImplRemapInfo vspec.MemberApparentEntity.Deref then ILMemberAccess.Public else access let m = vspec.Range - match StorageForVal m vspec eenv with + match StorageForVal cenv.g m vspec eenv with | Null -> GenExpr cenv cgbuf eenv SPSuppress rhsExpr discard @@ -5311,7 +5322,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s GenSetStorage m cgbuf storage | _ -> - let storage = StorageForVal m vspec eenv + let storage = StorageForVal cenv.g m vspec eenv match storage, rhsExpr with // locals are zero-init, no need to initialize them | Local (_, realloc, _), Expr.Const (Const.Zero, _, _) when not realloc -> @@ -5319,7 +5330,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s | _ -> GenBindingRhs cenv cgbuf eenv SPSuppress vspec rhsExpr CommitStartScope cgbuf startScopeMarkOpt - GenStoreVal cgbuf eenv vspec.Range vspec + GenStoreVal cenv cgbuf eenv vspec.Range vspec //------------------------------------------------------------------------- // Generate method bindings @@ -5492,7 +5503,7 @@ and GenParams cenv eenv (mspec: ILMethodSpec) (attribs: ArgReprInfo list) method (Set.empty, List.zip methodArgTys argInfosAndTypes) ||> List.mapFold (fun takenNames (methodArgTy, ((ilArgTy, topArgInfo), implValOpt)) -> let inFlag, outFlag, optionalFlag, defaultParamValue, Marshal, attribs = GenParamAttribs cenv methodArgTy topArgInfo.Attribs - + let idOpt = (match topArgInfo.Name with | Some v -> Some v | None -> match implValOpt with @@ -5502,14 +5513,19 @@ and GenParams cenv eenv (mspec: ILMethodSpec) (attribs: ArgReprInfo list) method let nmOpt, takenNames = match idOpt with | Some id -> - let nm = if takenNames.Contains(id.idText) then globalNng.FreshCompilerGeneratedName (id.idText, id.idRange) else id.idText + let nm = + if takenNames.Contains(id.idText) then + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName (id.idText, id.idRange) + else + id.idText Some nm, takenNames.Add nm | None -> None, takenNames - let ilAttribs = GenAttrs cenv eenv attribs - + let ilAttribs = match GenReadOnlyAttributeIfNecessary g methodArgTy with | Some attr -> ilAttribs @ [attr] @@ -5681,7 +5697,7 @@ and GenMethodForBinding match TryFindFSharpAttributeOpt g g.attrib_DllImportAttribute v.Attribs with | Some (Attrib(_, _, [ AttribStringArg dll ], namedArgs, _, _, m)) -> if not (isNil tps) then error(Error(FSComp.SR.ilSignatureForExternalFunctionContainsTypeParameters(), m)) - let hasPreserveSigNamedArg, mbody = GenPInvokeMethod (v.CompiledName, dll, namedArgs) + let hasPreserveSigNamedArg, mbody = GenPInvokeMethod (v.CompiledName g.CompilerGlobalState, dll, namedArgs) hasPreserveSigNamedArg, mbody, true | Some (Attrib(_, _, _, _, _, _, m)) -> @@ -5692,7 +5708,7 @@ and GenMethodForBinding // However still generate the code for reflection etc. let bodyExpr = if HasFSharpAttribute g g.attrib_NoDynamicInvocationAttribute v.Attribs then - let exnArg = mkString g m (FSComp.SR.ilDynamicInvocationNotSupported(v.CompiledName)) + let exnArg = mkString g m (FSComp.SR.ilDynamicInvocationNotSupported(v.CompiledName g.CompilerGlobalState)) let exnExpr = MakeNotSupportedExnExpr cenv eenv (exnArg, m) mkThrow m returnTy exnExpr else @@ -5791,20 +5807,20 @@ and GenMethodForBinding else let mdef = if not compileAsInstance then - mkILStaticMethod (ilMethTypars, v.CompiledName, access, ilParams, ilReturn, ilMethodBody) + mkILStaticMethod (ilMethTypars, v.CompiledName g.CompilerGlobalState, access, ilParams, ilReturn, ilMethodBody) elif (memberInfo.MemberFlags.IsDispatchSlot && memberInfo.IsImplemented) || memberInfo.MemberFlags.IsOverrideOrExplicitImpl then let flagFixups = ComputeFlagFixupsForMemberBinding cenv (v, memberInfo) - let mdef = mkILGenericVirtualMethod (v.CompiledName, ILMemberAccess.Public, ilMethTypars, ilParams, ilReturn, ilMethodBody) + let mdef = mkILGenericVirtualMethod (v.CompiledName g.CompilerGlobalState, ILMemberAccess.Public, ilMethTypars, ilParams, ilReturn, ilMethodBody) let mdef = List.fold (fun mdef f -> f mdef) mdef flagFixups // fixup can potentially change name of reflected definition that was already recorded - patch it if necessary cgbuf.mgbuf.ReplaceNameOfReflectedDefinition(v, mdef.Name) mdef else - mkILGenericNonVirtualMethod (v.CompiledName, access, ilMethTypars, ilParams, ilReturn, ilMethodBody) + mkILGenericNonVirtualMethod (v.CompiledName g.CompilerGlobalState, access, ilMethTypars, ilParams, ilReturn, ilMethodBody) let isAbstract = memberInfo.MemberFlags.IsDispatchSlot && @@ -5898,7 +5914,7 @@ and GenBindings cenv cgbuf eenv binds = List.iter (GenBinding cenv cgbuf eenv) b //------------------------------------------------------------------------- and GenSetVal cenv cgbuf eenv (vref, e, m) sequel = - let storage = StorageForValRef m vref eenv + let storage = StorageForValRef cenv.g m vref eenv match storage with | Env (ilCloTy, _, _, _) -> CG.EmitInstr cgbuf (pop 0) (Push [ilCloTy]) mkLdarg0 @@ -5910,7 +5926,7 @@ and GenSetVal cenv cgbuf eenv (vref, e, m) sequel = and GenGetValRefAndSequel cenv cgbuf eenv m (v: ValRef) fetchSequel = let ty = v.Type - GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv.amap m eenv.tyenv ty) (StorageForValRef m v eenv) fetchSequel + GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv.amap m eenv.tyenv ty) (StorageForValRef cenv.g m v eenv) fetchSequel and GenGetVal cenv cgbuf eenv (v: ValRef, m) sequel = GenGetValRefAndSequel cenv cgbuf eenv m v None @@ -5926,7 +5942,7 @@ and GenBindingRhs cenv cgbuf eenv sp (vspec: Val) e = | Expr.TyLambda (_, tyargs, body, _, ttype) when ( tyargs |> List.forall (fun tp -> tp.IsErased) && - (match StorageForVal vspec.Range vspec eenv with Local _ -> true | _ -> false) && + (match StorageForVal g vspec.Range vspec eenv with Local _ -> true | _ -> false) && (isLocalTypeFunc || (match ttype with TType_var typar -> match typar.Solution with Some(TType_app(t, _))-> t.IsStructOrEnumTycon | _ -> false @@ -6050,13 +6066,13 @@ and GenGetLocalVals cenv cgbuf eenvouter m fvs = List.iter (fun v -> GenGetLocalVal cenv cgbuf eenvouter m v None) fvs and GenGetLocalVal cenv cgbuf eenv m (vspec: Val) fetchSequel = - GenGetStorageAndSequel cenv cgbuf eenv m (vspec.Type, GenTypeOfVal cenv eenv vspec) (StorageForVal m vspec eenv) fetchSequel + GenGetStorageAndSequel cenv cgbuf eenv m (vspec.Type, GenTypeOfVal cenv eenv vspec) (StorageForVal cenv.g m vspec eenv) fetchSequel and GenGetLocalVRef cenv cgbuf eenv m (vref: ValRef) fetchSequel = - GenGetStorageAndSequel cenv cgbuf eenv m (vref.Type, GenTypeOfVal cenv eenv vref.Deref) (StorageForValRef m vref eenv) fetchSequel + GenGetStorageAndSequel cenv cgbuf eenv m (vref.Type, GenTypeOfVal cenv eenv vref.Deref) (StorageForValRef cenv.g m vref eenv) fetchSequel -and GenStoreVal cgbuf eenv m (vspec: Val) = - GenSetStorage vspec.Range cgbuf (StorageForVal m vspec eenv) +and GenStoreVal cenv cgbuf eenv m (vspec: Val) = + GenSetStorage vspec.Range cgbuf (StorageForVal cenv.g m vspec eenv) /// Allocate IL locals and AllocLocal cenv cgbuf eenv compgen (v, ty, isFixed) (scopeMarks: Mark * Mark) = @@ -6087,11 +6103,11 @@ and AllocLocalVal cenv cgbuf v eenv repr scopeMarks = let cloinfo, _, _ = GetIlxClosureInfo cenv v.Range true None eenvinner (Option.get repr) cloinfo - let idx, realloc, eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName, g.ilg.typ_Object, false) scopeMarks + let idx, realloc, eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName g.CompilerGlobalState, g.ilg.typ_Object, false) scopeMarks Local (idx, realloc, Some(ref (NamedLocalIlxClosureInfoGenerator cloinfoGenerate))), eenv | _ -> // normal local - let idx, realloc, eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName, GenTypeOfVal cenv eenv v, v.IsFixed) scopeMarks + let idx, realloc, eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName g.CompilerGlobalState, GenTypeOfVal cenv eenv v, v.IsFixed) scopeMarks Local (idx, realloc, None), eenv let eenv = AddStorageForVal g (v, notlazy repr) eenv Some repr, eenv @@ -6144,7 +6160,6 @@ and AllocTopValWithinExpr cenv cgbuf cloc scopeMarks v eenv = match storageOpt with | None -> NoShadowLocal, eenv | Some storage -> ShadowLocal storage, eenv - else NoShadowLocal, eenv @@ -6161,7 +6176,10 @@ and EmitSaveStack cenv cgbuf eenv m scopeMarks = let savedStack = (cgbuf.GetCurrentStack()) let savedStackLocals, eenvinner = (eenv, savedStack) ||> List.mapFold (fun eenv ty -> - let idx, _realloc, eenv = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("spill", m), ty, false) scopeMarks + let idx, _realloc, eenv = + // Ensure that we have an g.CompilerGlobalState + assert(cenv.g.CompilerGlobalState |> Option.isSome) + AllocLocal cenv cgbuf eenv true (cenv.g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("spill", m), ty, false) scopeMarks idx, eenv) List.iter (EmitSetLocal cgbuf) savedStackLocals cgbuf.AssertEmptyStack() @@ -6177,9 +6195,9 @@ and EmitRestoreStack cgbuf (savedStack, savedStackLocals) = //------------------------------------------------------------------------- and GenAttribArg amap g eenv x (ilArgTy: ILType) = + let exprL expr = exprL g expr match x, ilArgTy with - // Detect 'null' used for an array argument | Expr.Const (Const.Zero, _, _), ILType.Array _ -> ILAttribElem.Null @@ -6377,7 +6395,7 @@ and GenModuleBinding cenv (cgbuf: CodeGenBuffer) (qname: QualifiedNameOfFile) la GenLetRecBindings cenv cgbuf eenv ([bind], m) | ModuleOrNamespaceBinding.Module (mspec, mdef) -> - let hidden = IsHiddenTycon eenv.sigToImplRemapInfo mspec + let hidden = IsHiddenTycon cenv.g eenv.sigToImplRemapInfo mspec let eenvinner = if mspec.IsNamespace then eenv else @@ -6616,7 +6634,7 @@ and GenAbstractBinding cenv eenv tref (vref: ValRef) = let ilParams = GenParams cenv eenvForMeth mspec argInfos methodArgTys None let compileAsInstance = ValRefIsCompiledAsInstanceMember g vref - let mdef = mkILGenericVirtualMethod (vref.CompiledName, ILMemberAccess.Public, ilMethTypars, ilParams, ilReturn, MethodBody.Abstract) + let mdef = mkILGenericVirtualMethod (vref.CompiledName g.CompilerGlobalState, ILMemberAccess.Public, ilMethTypars, ilParams, ilReturn, MethodBody.Abstract) let mdef = fixupVirtualSlotFlags mdef let mdef = @@ -6716,8 +6734,8 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let ilIntfTys = tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv.amap m eenvinner.tyenv) let ilTypeName = tref.Name - let hidden = IsHiddenTycon eenv.sigToImplRemapInfo tycon - let hiddenRepr = hidden || IsHiddenTyconRepr eenv.sigToImplRemapInfo tycon + let hidden = IsHiddenTycon g eenv.sigToImplRemapInfo tycon + let hiddenRepr = hidden || IsHiddenTyconRepr g eenv.sigToImplRemapInfo tycon let access = ComputeTypeAccess tref hidden // The implicit augmentation doesn't actually create CompareTo(object) or Object.Equals @@ -7300,7 +7318,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = | TExnFresh _ -> let ilThisTy = GenExnType cenv.amap m eenv.tyenv exncref let tref = ilThisTy.TypeRef - let isHidden = IsHiddenTycon eenv.sigToImplRemapInfo exnc + let isHidden = IsHiddenTycon g eenv.sigToImplRemapInfo exnc let access = ComputeTypeAccess tref isHidden let reprAccess = ComputeMemberAccess isHidden let fspecs = exnc.TrueInstanceFieldsAsList @@ -7563,7 +7581,7 @@ let LookupGeneratedValue (amap: ImportMap) (ctxt: ExecutionContext) eenv (v: Val let ilTy = GenType amap v.Range TypeReprEnv.Empty v.Type (* TypeReprEnv.Empty ok, not expecting typars *) ctxt.LookupType ilTy // Lookup the compiled v value (as an object). - match StorageForVal v.Range v eenv with + match StorageForVal amap.g v.Range v eenv with | StaticField (fspec, _, hasLiteralAttr, ilContainerTy, _, _, ilGetterMethRef, _, _) -> let obj = if hasLiteralAttr then @@ -7603,9 +7621,9 @@ let LookupGeneratedValue (amap: ImportMap) (ctxt: ExecutionContext) eenv (v: Val None // Invoke the set_Foo method for a declaration with a default/null value. Used to release storage in fsi.exe -let ClearGeneratedValue (ctxt: ExecutionContext) (_g: TcGlobals) eenv (v: Val) = +let ClearGeneratedValue (ctxt: ExecutionContext) (g: TcGlobals) eenv (v: Val) = try - match StorageForVal v.Range v eenv with + match StorageForVal g v.Range v eenv with | StaticField (fspec, _, hasLiteralAttr, _, _, _, _ilGetterMethRef, ilSetterMethRef, _) -> if not hasLiteralAttr && v.IsMutable then let staticTy = ctxt.LookupTypeRef ilSetterMethRef.DeclaringTypeRef diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 1ff7ed3c7c1..fabd5583c23 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -771,6 +771,8 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Zmap Option.isSome) + g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName(name, m) let fHat = mkLocalNameTypeArity f.IsCompilerGenerated m fHatName fHatTy (Some fHatArity) fHat diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 912a4035280..5a8d66c875b 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -654,7 +654,8 @@ let BuildObjCtorCall (g: TcGlobals) m = let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = let arities = (arityOfVal vref.Deref).AritiesOfArgs - let args3, (leftover, retTy) = + let args3, (leftover, retTy) = + let exprL expr = exprL g expr ((args, vexprty), arities) ||> List.mapFold (fun (args, fty) arity -> match arity, args with | (0|1), [] when typeEquiv g (domainOfFunTy g fty) g.unit_ty -> mkUnit g m, (args, rangeOfFunTy g fty) @@ -728,7 +729,7 @@ let TryImportProvidedMethodBaseAsLibraryIntrinsic (amap: Import.ImportMap, m: ra match amap.g.knownFSharpCoreModules.TryGetValue declaringEntity.LogicalName with | true, modRef -> modRef.ModuleOrNamespaceType.AllValsByLogicalName - |> Seq.tryPick (fun (KeyValue(_, v)) -> if v.CompiledName = methodName then Some (mkNestedValRef modRef v) else None) + |> Seq.tryPick (fun (KeyValue(_, v)) -> if (v.CompiledName amap.g.CompilerGlobalState) = methodName then Some (mkNestedValRef modRef v) else None) | _ -> None else None diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 2eea2ef8db4..ecc24b91317 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -172,7 +172,8 @@ let braceL x = leftL (tagText "{") ^^ x ^^ rightL (tagText "}") let seqL xL xs = Seq.fold (fun z x -> z @@ xL x) emptyL xs let namemapL xL xmap = NameMap.foldBack (fun nm x z -> xL nm x @@ z) xmap emptyL -let rec exprValueInfoL g exprVal = +let rec exprValueInfoL g exprVal = + let exprL expr = exprL g expr match exprVal with | ConstValue (x, ty) -> NicePrint.layoutConst g ty x | UnknownValue -> wordL (tagText "?") diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 41135afed53..03718e8fe5a 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -348,6 +348,7 @@ let rec CombineRefutations g r1 r2 = let ShowCounterExample g denv m refuted = try + let exprL expr = exprL g expr let refutations = refuted |> List.collect (function RefutedWhenClause -> [] | (RefutedInvestigation(path, discrim)) -> [RefuteDiscrimSet g m path discrim]) let counterExample, enumCoversKnown = match refutations with diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index ddbad8f09eb..b6a286c5d79 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -1733,7 +1733,7 @@ and CheckBinding cenv env alwaysCheckNoReraise context (TBind(v, bindRhs, _) as let _, _, argExprs = qscope.Close() if not (isNil argExprs) then errorR(Error(FSComp.SR.chkReflectedDefCantSplice(), v.Range)) - QuotationTranslator.ConvMethodBase qscope env (v.CompiledName, v) |> ignore + QuotationTranslator.ConvMethodBase qscope env (v.CompiledName g.CompilerGlobalState, v) |> ignore with | QuotationTranslator.InvalidQuotedTerm e -> errorR e @@ -1855,12 +1855,12 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = check false v.CoreDisplayName check false v.DisplayName - check false v.CompiledName + check false (v.CompiledName cenv.g.CompilerGlobalState) // Check if an F# extension member clashes if v.IsExtensionMember then tcref.ModuleOrNamespaceType.AllValsAndMembersByLogicalNameUncached.[v.LogicalName] |> List.iter (fun v2 -> - if v2.IsExtensionMember && not (valEq v v2) && v.CompiledName = v2.CompiledName then + if v2.IsExtensionMember && not (valEq v v2) && (v.CompiledName cenv.g.CompilerGlobalState) = (v2.CompiledName cenv.g.CompilerGlobalState) then let minfo1 = FSMeth(g, generalizedTyconRef tcref, mkLocalValRef v, Some 0UL) let minfo2 = FSMeth(g, generalizedTyconRef tcref, mkLocalValRef v2, Some 0UL) if tyconRefEq g v.MemberApparentEntity v2.MemberApparentEntity && @@ -1896,8 +1896,8 @@ let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = let m = rfield.Range let fieldTy = stripTyEqns cenv.g rfield.FormalType let isHidden = - IsHiddenTycon env.sigToImplRemapInfo tycon || - IsHiddenTyconRepr env.sigToImplRemapInfo tycon || + IsHiddenTycon cenv.g env.sigToImplRemapInfo tycon || + IsHiddenTyconRepr cenv.g env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility CheckTypeForAccess cenv env (fun () -> rfield.Name) access m fieldTy @@ -2159,7 +2159,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = uc.RecdFieldsArray |> Array.iter (CheckRecdField true cenv env tycon)) // Access checks - let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility + let access = AdjustAccess (IsHiddenTycon g env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index ecbe10d5ad2..cf4e4e17456 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -314,7 +314,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. let argTys = curriedArgInfos |> List.concat |> List.map fst let methArgTypesR = ConvTypes cenv envinner m argTys let methRetTypeR = ConvReturnType cenv envinner m retTy - let methName = vref.CompiledName + let methName = vref.CompiledName cenv.g.CompilerGlobalState let numGenericArgs = tyargs.Length - numEnclTypeArgs ConvObjectModelCall cenv env m (isPropGet, isPropSet, isNewObj, parentTyconR, methArgTypesR, methRetTypeR, methName, tyargs, numGenericArgs, callArgs) else @@ -551,7 +551,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. match vref.DeclaringEntity with | Parent tcref when IsCompiledAsStaticProperty cenv.g vref.Deref -> let parentTyconR = ConvTyconRef cenv tcref m - let propName = vref.CompiledName + let propName = vref.CompiledName cenv.g.CompilerGlobalState let propTy = ConvType cenv env m vref.Type QP.mkPropSet( (parentTyconR, propName, propTy, []), [], [ConvExpr cenv env e]) | _ -> @@ -742,7 +742,7 @@ and ConvModuleValueAppCore cenv env m (vref: ValRef) tyargs (args: Expr list lis let isProperty = IsCompiledAsStaticProperty cenv.g vref.Deref let tcrefR = ConvTyconRef cenv tcref m let tyargsR = ConvTypes cenv env m tyargs - let nm = vref.CompiledName + let nm = vref.CompiledName cenv.g.CompilerGlobalState let argsR = List.map (ConvExprs cenv env) args QP.mkModuleValueApp(tcrefR, nm, isProperty, tyargsR, argsR) @@ -796,7 +796,7 @@ and ConvRecdFieldRef cenv (rfref: RecdFieldRef) m = and ConvVal cenv env (v: Val) = let tyR = ConvType cenv env v.Range v.Type - QP.freshVar (v.CompiledName, tyR, v.IsMutable) + QP.freshVar (v.CompiledName cenv.g.CompilerGlobalState, tyR, v.IsMutable) and ConvTyparRef cenv env m (tp: Typar) = match env.tyvs.TryFind tp.Stamp with diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index 6ba6dad410c..b367987e173 100644 --- a/src/fsharp/SignatureConformance.fs +++ b/src/fsharp/SignatureConformance.fs @@ -305,7 +305,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = let m = implVal.Range if implVal.IsMutable <> sigVal.IsMutable then (err denv FSComp.SR.ValueNotContainedMutabilityAttributesDiffer) elif implVal.LogicalName <> sigVal.LogicalName then (err denv FSComp.SR.ValueNotContainedMutabilityNamesDiffer) - elif implVal.CompiledName <> sigVal.CompiledName then (err denv FSComp.SR.ValueNotContainedMutabilityCompiledNamesDiffer) + elif (implVal.CompiledName g.CompilerGlobalState) <> (sigVal.CompiledName g.CompilerGlobalState) then (err denv FSComp.SR.ValueNotContainedMutabilityCompiledNamesDiffer) elif implVal.DisplayName <> sigVal.DisplayName then (err denv FSComp.SR.ValueNotContainedMutabilityDisplayNamesDiffer) elif isLessAccessible implVal.Accessibility sigVal.Accessibility then (err denv FSComp.SR.ValueNotContainedMutabilityAccessibilityMore) elif implVal.MustInline <> sigVal.MustInline then (err denv FSComp.SR.ValueNotContainedMutabilityInlineFlagsDiffer) @@ -369,7 +369,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = match implMemberInfo, sigMemberInfo with | None, None -> true | Some implMembInfo, Some sigMembInfo -> - if not (implVal.CompiledName = sigVal.CompiledName) then + if not ((implVal.CompiledName g.CompilerGlobalState) = (sigVal.CompiledName g.CompilerGlobalState)) then err(FSComp.SR.ValueNotContainedMutabilityDotNetNamesDiffer) elif not (implMembInfo.MemberFlags.IsInstance = sigMembInfo.MemberFlags.IsInstance) then err(FSComp.SR.ValueNotContainedMutabilityStaticsDiffer) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 4743ff03dfc..00fb9a08278 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -3234,7 +3234,6 @@ let (|TypeDefOfExpr|_|) g expr = //-------------------------------------------------------------------------- // DEBUG layout //--------------------------------------------------------------------------- - module DebugPrint = let layoutRanges = ref false @@ -3468,14 +3467,13 @@ module DebugPrint = | ILAttrib ilmeth -> wordL (tagText ilmeth.Name) | FSAttrib vref -> valRefL vref) ^^ rightL (tagText ">]") - + let layoutAttribs attribs = aboveListL (List.map layoutAttrib attribs) let arityInfoL (ValReprInfo (tpNames, _, _) as tvd) = let ns = tvd.AritiesOfArgs in leftL (tagText "arity<") ^^ intL tpNames.Length ^^ sepL (tagText ">[") ^^ commaListL (List.map intL ns) ^^ rightL (tagText "]") - let valL (v: Val) = let vsL = wordL (tagText (DecompileOpName v.LogicalName)) |> stampL v.Stamp let vsL = vsL -- layoutAttribs (v.Attribs) @@ -3511,18 +3509,18 @@ module DebugPrint = wordL(tagText "slotsig") #endif - let rec memberL (v: Val) (membInfo: ValMemberInfo) = + let rec memberL (g:TcGlobals) (v: Val) (membInfo: ValMemberInfo) = aboveListL - [ wordL(tagText "compiled_name! = ") ^^ wordL (tagText v.CompiledName) + [ wordL(tagText "compiled_name! = ") ^^ wordL (tagText (v.CompiledName g.CompilerGlobalState)) wordL(tagText "membInfo-slotsig! = ") ^^ listL slotSigL membInfo.ImplementedSlotSigs ] - and valAtBindL v = + and valAtBindL g v = let vL = valL v let mutL = (if v.IsMutable then wordL(tagText "mutable") ++ vL else vL) mutL --- aboveListL [ yield wordL(tagText ":") ^^ typeL v.Type - match v.MemberInfo with None -> () | Some mem_info -> yield wordL(tagText "!") ^^ memberL v mem_info + match v.MemberInfo with None -> () | Some mem_info -> yield wordL(tagText "!") ^^ memberL g v mem_info match v.ValReprInfo with None -> () | Some arity_info -> yield wordL(tagText "#") ^^ arityInfoL arity_info] let unionCaseRefL (ucr: UnionCaseRef) = wordL (tagText ucr.CaseName) @@ -3563,9 +3561,9 @@ module DebugPrint = | Const.Zero -> "default" wordL (tagText str) - let rec tyconL (tycon: Tycon) = - if tycon.IsModuleOrNamespace then entityL tycon else - + let rec tyconL g (tycon: Tycon) = + if tycon.IsModuleOrNamespace then entityL g tycon else + let lhsL = wordL (tagText (match tycon.TypeOrMeasureKind with TyparKind.Measure -> "[] type" | TyparKind.Type -> "type")) ^^ wordL (tagText tycon.DisplayName) ^^ layoutTyparDecls tycon.TyparsNoRange let lhsL = lhsL --- layoutAttribs tycon.Attribs let memberLs = @@ -3585,7 +3583,7 @@ module DebugPrint = emptyL else let iimplsLs = iimpls |> List.map (fun (ty, _, _) -> wordL(tagText "interface") --- typeL ty) - let adhocLs = adhoc |> List.map (fun vref -> valAtBindL vref.Deref) + let adhocLs = adhoc |> List.map (fun vref -> valAtBindL g vref.Deref) (wordL(tagText "with") @@-- aboveListL (iimplsLs @ adhocLs)) @@ wordL(tagText "end") let layoutUnionCaseArgTypes argtys = sepListL (wordL(tagText "*")) (List.map typeL argtys) @@ -3632,7 +3630,7 @@ module DebugPrint = let vsprs = tycon.MembersOfFSharpTyconSorted |> List.filter (fun v -> v.IsDispatchSlot) - |> List.map (fun vref -> valAtBindL vref.Deref) + |> List.map (fun vref -> valAtBindL g vref.Deref) let vals = tycon.TrueFieldsAsList |> List.map (fun f -> (if f.IsStatic then wordL(tagText "static") else emptyL) ^^ wordL(tagText "val") ^^ layoutRecdField f) let alldecls = inherits @ vsprs @ vals let emptyMeasure = match tycon.TypeOrMeasureKind with TyparKind.Measure -> isNil alldecls | _ -> false @@ -3658,25 +3656,31 @@ module DebugPrint = (lhsL ^^ wordL(tagText "=")) @@-- rhsL reprL - and bindingL (TBind(v, repr, _)) = - valAtBindL v --- (wordL(tagText "=") ^^ exprL repr) + and bindingL g (TBind(v, repr, _)) = + valAtBindL g v --- (wordL(tagText "=") ^^ exprL g repr) - and exprL expr = exprWrapL false expr + and exprL g expr = exprWrapL g false expr - and atomL expr = exprWrapL true expr // true means bracket if needed to be atomic expr + and atomL g expr = exprWrapL g true expr // true means bracket if needed to be atomic expr - and letRecL binds bodyL = + and letRecL g binds bodyL = let eqnsL = binds - |> List.mapHeadTail (fun bind -> wordL(tagText "rec") ^^ bindingL bind ^^ wordL(tagText "in")) - (fun bind -> wordL(tagText "and") ^^ bindingL bind ^^ wordL(tagText "in")) + |> List.mapHeadTail (fun bind -> wordL(tagText "rec") ^^ bindingL g bind ^^ wordL(tagText "in")) + (fun bind -> wordL(tagText "and") ^^ bindingL g bind ^^ wordL(tagText "in")) (aboveListL eqnsL @@ bodyL) - and letL bind bodyL = - let eqnL = wordL(tagText "let") ^^ bindingL bind ^^ wordL(tagText "in") + and letL g bind bodyL = + let eqnL = wordL(tagText "let") ^^ bindingL g bind ^^ wordL(tagText "in") (eqnL @@ bodyL) - and exprWrapL isAtomic expr = + and exprWrapL g isAtomic expr = + let atomL args = atomL g args + let exprL expr = exprL g expr + let iimplL iimpls = iimplL g iimpls + let valAtBindL v = valAtBindL g v + let overrideL tmeth = overrideL g tmeth + let targetL targets = targetL g targets let wrap = bracketIfL isAtomic // wrap iff require atomic expr let lay = match expr with @@ -3710,15 +3714,15 @@ module DebugPrint = ((wordL(tagText "CHOOSE") ^^ spaceListL (List.map typarL argtyvs) ^^ rightL(tagText ".")) ++ exprL body) |> wrap | Expr.App (f, _, tys, argtys, _) -> let flayout = atomL f - appL flayout tys argtys |> wrap + appL g flayout tys argtys |> wrap | Expr.LetRec (binds, body, _, _) -> - letRecL binds (exprL body) |> wrap + letRecL g binds (exprL body) |> wrap | Expr.Let (bind, body, _, _) -> - letL bind (exprL body) |> wrap + letL g bind (exprL body) |> wrap | Expr.Link rX -> (wordL(tagText "RecLink") --- atomL (!rX)) |> wrap | Expr.Match (_, _, dtree, targets, _, _) -> - leftL(tagText "[") ^^ (decisionTreeL dtree @@ aboveListL (List.mapi targetL (targets |> Array.toList)) ^^ rightL(tagText "]")) + leftL(tagText "[") ^^ (decisionTreeL g dtree @@ aboveListL (List.mapi targetL (targets |> Array.toList)) ^^ rightL(tagText "]")) | Expr.Op (TOp.UnionCase c, _, args, _) -> (unionCaseRefL c ++ spaceListL (List.map atomL args)) |> wrap | Expr.Op (TOp.ExnConstr ecref, _, args, _) -> @@ -3762,7 +3766,7 @@ module DebugPrint = | Expr.Op (TOp.ILAsm (a, tys), tyargs, args, _) -> let instrs = a |> List.map (sprintf "%+A" >> tagText >> wordL) |> spaceListL // %+A has + since instrs are from an "internal" type let instrs = leftL(tagText "(#") ^^ instrs ^^ rightL(tagText "#)") - (appL instrs tyargs args --- + (appL g instrs tyargs args --- wordL(tagText ":") ^^ spaceListL (List.map typeAtomL tys)) |> wrap | Expr.Op (TOp.LValueOp (lvop, vr), _, args, _) -> (lvalopL lvop ^^ valRefL vr --- bracketL (commaListL (List.map atomL args))) |> wrap @@ -3814,92 +3818,104 @@ module DebugPrint = then leftL(tagText "{") ^^ (rangeL expr.Range ^^ rightL(tagText ":")) ++ lay ^^ rightL(tagText "}") else lay - and implFilesL implFiles = + and implFilesL g implFiles = + let implFileL implFiles = implFileL g implFiles aboveListL (List.map implFileL implFiles) - and appL flayout tys args = + and appL g flayout tys args = + let atomL args = atomL g args let z = flayout let z = z ^^ instL typeL tys let z = z --- sepL(tagText "`") --- (spaceListL (List.map atomL args)) z - - and implFileL (TImplFile (_, _, mexpr, _, _, _)) = - aboveListL [(wordL(tagText "top implementation ")) @@-- mexprL mexpr] - and mexprL x = + and implFileL g (TImplFile (_, _, mexpr, _, _, _)) = + aboveListL [(wordL(tagText "top implementation ")) @@-- mexprL g mexpr] + + and mexprL g x = match x with - | ModuleOrNamespaceExprWithSig(mtyp, defs, _) -> mdefL defs @@- (wordL(tagText ":") @@- entityTypeL mtyp) + | ModuleOrNamespaceExprWithSig(mtyp, defs, _) -> mdefL g defs @@- (wordL(tagText ":") @@- entityTypeL g mtyp) - and mdefsL defs = wordL(tagText "Module Defs") @@-- aboveListL(List.map mdefL defs) + and mdefsL g defs = + let mdefL x = mdefL g x + wordL(tagText "Module Defs") @@-- aboveListL(List.map mdefL defs) - and mdefL x = - match x with + and mdefL g x = + let tyconL tycon = tyconL g tycon + let mbindL x = mbindL g x + match x with | TMDefRec(_, tycons, mbinds, _) -> aboveListL ((tycons |> List.map tyconL) @ List.map mbindL mbinds) - | TMDefLet(bind, _) -> letL bind emptyL - | TMDefDo(e, _) -> exprL e - | TMDefs defs -> mdefsL defs - | TMAbstract mexpr -> mexprL mexpr - - and mbindL x = - match x with - | ModuleOrNamespaceBinding.Binding bind -> letL bind emptyL + | TMDefLet(bind, _) -> letL g bind emptyL + | TMDefDo(e, _) -> exprL g e + | TMDefs defs -> mdefsL g defs + | TMAbstract mexpr -> mexprL g mexpr + + and mbindL g x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> letL g bind emptyL | ModuleOrNamespaceBinding.Module(mspec, rhs) -> - (wordL (tagText (if mspec.IsNamespace then "namespace" else "module")) ^^ (wordL (tagText mspec.DemangledModuleOrNamespaceName) |> stampL mspec.Stamp)) @@-- mdefL rhs + (wordL (tagText (if mspec.IsNamespace then "namespace" else "module")) ^^ (wordL (tagText mspec.DemangledModuleOrNamespaceName) |> stampL mspec.Stamp)) @@-- mdefL g rhs - and entityTypeL (mtyp: ModuleOrNamespaceType) = + and entityTypeL g (mtyp: ModuleOrNamespaceType) = + let tyconL tycon = tyconL g tycon aboveListL [jlistL typeOfValL mtyp.AllValsAndMembers - jlistL tyconL mtyp.AllEntities;] + jlistL tyconL mtyp.AllEntities] - and entityL (ms: ModuleOrNamespace) = + and entityL g (ms: ModuleOrNamespace) = let header = wordL(tagText "module") ^^ (wordL (tagText ms.DemangledModuleOrNamespaceName) |> stampL ms.Stamp) ^^ wordL(tagText ":") let footer = wordL(tagText "end") - let body = entityTypeL ms.ModuleOrNamespaceType + let body = entityTypeL g ms.ModuleOrNamespaceType (header @@-- body) @@ footer - and ccuL (ccu: CcuThunk) = entityL ccu.Contents + and ccuL g (ccu: CcuThunk) = entityL g ccu.Contents - and decisionTreeL x = + and decisionTreeL g x = + let exprL expr = exprL g expr + let dcaseL dcases = dcaseL g dcases match x with | TDBind (bind, body) -> - let bind = wordL(tagText "let") ^^ bindingL bind ^^ wordL(tagText "in") - (bind @@ decisionTreeL body) + let bind = wordL(tagText "let") ^^ bindingL g bind ^^ wordL(tagText "in") + (bind @@ decisionTreeL g body) | TDSuccess (args, n) -> wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map exprL) - | TDSwitch (test, dcases, dflt, _) -> + | TDSwitch (test, dcases, dflt, _) -> (wordL(tagText "Switch") --- exprL test) @@-- (aboveListL (List.map dcaseL dcases) @@ match dflt with | None -> emptyL - | Some dtree -> wordL(tagText "dflt:") --- decisionTreeL dtree) + | Some dtree -> wordL(tagText "dflt:") --- decisionTreeL g dtree) - and dcaseL (TCase (test, dtree)) = (dtestL test ^^ wordL(tagText "//")) --- decisionTreeL dtree + and dcaseL g (TCase (test, dtree)) = (dtestL g test ^^ wordL(tagText "//")) --- decisionTreeL g dtree - and dtestL x = + and dtestL g x = match x with | (DecisionTreeTest.UnionCase (c, tinst)) -> wordL(tagText "is") ^^ unionCaseRefL c ^^ instL typeL tinst | (DecisionTreeTest.ArrayLength (n, ty)) -> wordL(tagText "length") ^^ intL n ^^ typeL ty | (DecisionTreeTest.Const c) -> wordL(tagText "is") ^^ constL c | (DecisionTreeTest.IsNull ) -> wordL(tagText "isnull") | (DecisionTreeTest.IsInst (_, ty)) -> wordL(tagText "isinst") ^^ typeL ty - | (DecisionTreeTest.ActivePatternCase (exp, _, _, _, _)) -> wordL(tagText "query") ^^ exprL exp + | (DecisionTreeTest.ActivePatternCase (exp, _, _, _, _)) -> wordL(tagText "query") ^^ exprL g exp - and targetL i (TTarget (argvs, body, _)) = leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL body + and targetL g i (TTarget (argvs, body, _)) = leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL g body and flatValsL vs = vs |> List.map valL - and tmethodL (TObjExprMethod(TSlotSig(nm, _, _, _, _, _), _, tps, vs, e, _)) = + and tmethodL g (TObjExprMethod(TSlotSig(nm, _, _, _, _, _), _, tps, vs, e, _)) = + let valAtBindL v = valAtBindL g v (wordL(tagText "TObjExprMethod") --- (wordL (tagText nm)) ^^ wordL(tagText "=")) -- (wordL(tagText "METH-LAM") --- angleBracketListL (List.map typarL tps) ^^ rightL(tagText ".")) --- (wordL(tagText "meth-lam") --- tupleL (List.map (List.map valAtBindL >> tupleL) vs) ^^ rightL(tagText ".")) --- - (atomL e) + (atomL g e) - and overrideL tmeth = wordL(tagText "with") ^^ tmethodL tmeth + and overrideL g tmeth = wordL(tagText "with") ^^ tmethodL g tmeth - and iimplL (ty, tmeths) = wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map tmethodL tmeths) + and iimplL g (ty, tmeths) = + let tmethodL p = tmethodL g p + wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map tmethodL tmeths) let showType x = Layout.showL (typeL x) - let showExpr x = Layout.showL (exprL x) + let showExpr g x = Layout.showL (exprL g x) let traitL x = auxTraitL SimplifyTypes.typeSimplificationInfo0 x @@ -4198,9 +4214,13 @@ let IsHidden setF accessF remapF debugF = let res = check mrmi x if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res res - -let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.HiddenTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.HiddenTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x + +let IsHiddenTycon g mrmi x = + let debugPrint x = DebugPrint.tyconL g x + IsHidden (fun mhi -> mhi.HiddenTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) debugPrint mrmi x +let IsHiddenTyconRepr g mrmi x = + let debugPrint x = DebugPrint.tyconL g x + IsHidden (fun mhi -> mhi.HiddenTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) debugPrint mrmi x let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.HiddenVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.HiddenRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) DebugPrint.recdFieldRefL mrmi x @@ -5278,16 +5298,16 @@ and copyAndRemapAndBindModTy g compgen tmenv mty = let _, _, tmenvinner = copyAndRemapAndBindTyconsAndVals g compgen tmenv tycons vs remapModTy g compgen tmenvinner mty, tmenvinner -and remapModTy _g _compgen tmenv mty = - mapImmediateValsAndTycons (renameTycon tmenv) (renameVal tmenv) mty +and remapModTy g _compgen tmenv mty = + mapImmediateValsAndTycons (renameTycon g tmenv) (renameVal tmenv) mty -and renameTycon tyenv x = +and renameTycon g tyenv x = let tcref = - try + try let res = tyenv.tyconRefRemap.[mkLocalTyconRef x] res with :? KeyNotFoundException -> - errorR(InternalError("couldn't remap internal tycon " + showL(DebugPrint.tyconL x), x.Range)) + errorR(InternalError("couldn't remap internal tycon " + showL(DebugPrint.tyconL g x), x.Range)) mkLocalTyconRef x tcref.Deref @@ -5323,17 +5343,17 @@ and copyAndRemapAndBindTyconsAndVals g compgen tmenv tycons vs = mkLocalValRef v vref.Deref - let lookupTycon tycon = + let lookupTycon g tycon = let tcref = try let res = tmenvinner.tyconRefRemap.[mkLocalTyconRef tycon] res with :? KeyNotFoundException -> - errorR(InternalError("couldn't remap internal tycon " + showL(DebugPrint.tyconL tycon), tycon.Range)) + errorR(InternalError("couldn't remap internal tycon " + showL(DebugPrint.tyconL g tycon), tycon.Range)) mkLocalTyconRef tycon tcref.Deref - - (tycons, tycons') ||> List.iter2 (fun tcd tcd' -> + (tycons, tycons') ||> List.iter2 (fun tcd tcd' -> + let lookupTycon tycon = lookupTycon g tycon let tps', tmenvinner2 = tmenvCopyRemapAndBindTypars (remapAttribs g tmenvinner) tmenvinner (tcd.entity_typars.Force(tcd.entity_range)) tcd'.entity_typars <- LazyWithContext.NotLazy tps' tcd'.entity_attribs <- tcd.entity_attribs |> remapAttribs g tmenvinner2 @@ -5415,7 +5435,7 @@ and remapAndRenameModDef g compgen tmenv mdef = match mdef with | TMDefRec(isRec, tycons, mbinds, m) -> // Abstract (virtual) vslots in the tycons at TMDefRec nodes are binders. They also need to be copied and renamed. - let tycons = tycons |> List.map (renameTycon tmenv) + let tycons = tycons |> List.map (renameTycon g tmenv) let mbinds = mbinds |> List.map (remapAndRenameModBind g compgen tmenv) TMDefRec(isRec, tycons, mbinds, m) | TMDefLet(bind, m) -> @@ -5439,7 +5459,7 @@ and remapAndRenameModBind g compgen tmenv x = let bind2 = remapAndRenameBind g compgen tmenv bind v2 ModuleOrNamespaceBinding.Binding bind2 | ModuleOrNamespaceBinding.Module(mspec, def) -> - let mspec = renameTycon tmenv mspec + let mspec = renameTycon g tmenv mspec let def = remapAndRenameModDef g compgen tmenv def ModuleOrNamespaceBinding.Module(mspec, def) @@ -7781,7 +7801,7 @@ let XmlDocSigOfVal g path (v: Val) = match membInfo.MemberFlags.MemberKind with | MemberKind.ClassConstructor | MemberKind.Constructor -> "M:", "#ctor" - | MemberKind.Member -> "M:", v.CompiledName + | MemberKind.Member -> "M:", v.CompiledName g.CompilerGlobalState | MemberKind.PropertyGetSet | MemberKind.PropertySet | MemberKind.PropertyGet -> "P:", v.PropertyName @@ -7795,7 +7815,7 @@ let XmlDocSigOfVal g path (v: Val) = // Regular F# values and extension members let w = arityOfVal v let tps, argInfos, _, _ = GetTopValTypeInCompiledForm g w v.Type v.Range - let name = v.CompiledName + let name = v.CompiledName g.CompilerGlobalState let prefix = if w.NumCurriedArgs = 0 && isNil tps then "P:" else "M:" @@ -8897,7 +8917,6 @@ let BindUnitVars g (mvs: Val list, paramInfos: ArgReprInfo list, body) = [], mkLet NoSequencePointAtInvisibleBinding v.Range v (mkUnit g v.Range) body | _ -> mvs, body - let isThreadOrContextStatic g attrs = HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute attrs || HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute attrs @@ -8905,5 +8924,3 @@ let isThreadOrContextStatic g attrs = let mkUnitDelayLambda (g: TcGlobals) m e = let uv, _ = mkCompGenLocal m "unitVar" g.unit_ty mkLambda m uv (e, tyOfExpr g e) - - diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index f9011081bbf..8c71736a844 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -1205,10 +1205,10 @@ val MakeExportRemapping : CcuThunk -> ModuleOrNamespace -> Remap val ApplyExportRemappingToEntity : TcGlobals -> Remap -> ModuleOrNamespace -> ModuleOrNamespace /// Determine if a type definition is hidden by a signature -val IsHiddenTycon : (Remap * SignatureHidingInfo) list -> Tycon -> bool +val IsHiddenTycon : TcGlobals -> (Remap * SignatureHidingInfo) list -> Tycon -> bool /// Determine if the representation of a type definition is hidden by a signature -val IsHiddenTyconRepr : (Remap * SignatureHidingInfo) list -> Tycon -> bool +val IsHiddenTyconRepr : TcGlobals -> (Remap * SignatureHidingInfo) list -> Tycon -> bool /// Determine if a member, function or value is hidden by a signature val IsHiddenVal : (Remap * SignatureHidingInfo) list -> Val -> bool @@ -1290,7 +1290,7 @@ module DebugPrint = val showType : TType -> string /// Convert an expression to a string for debugging purposes - val showExpr : Expr -> string + val showExpr : TcGlobals -> Expr -> string /// Debug layout for a reference to a value val valRefL : ValRef -> layout @@ -1299,7 +1299,7 @@ module DebugPrint = val unionCaseRefL : UnionCaseRef -> layout /// Debug layout for an value definition at its binding site - val valAtBindL : Val -> layout + val valAtBindL : TcGlobals -> Val -> layout /// Debug layout for an integer val intL : int -> layout @@ -1326,31 +1326,31 @@ module DebugPrint = val slotSigL : SlotSig -> layout /// Debug layout for the type signature of a module or namespace definition - val entityTypeL : ModuleOrNamespaceType -> layout + val entityTypeL : TcGlobals -> ModuleOrNamespaceType -> layout /// Debug layout for a module or namespace definition - val entityL : ModuleOrNamespace -> layout + val entityL : TcGlobals -> ModuleOrNamespace -> layout /// Debug layout for the type of a value val typeOfValL : Val -> layout /// Debug layout for a binding of an expression to a value - val bindingL : Binding -> layout + val bindingL : TcGlobals -> Binding -> layout /// Debug layout for an expression - val exprL : Expr -> layout + val exprL : TcGlobals -> Expr -> layout /// Debug layout for a type definition - val tyconL : Tycon -> layout + val tyconL : TcGlobals -> Tycon -> layout /// Debug layout for a decision tree - val decisionTreeL : DecisionTree -> layout + val decisionTreeL : TcGlobals -> DecisionTree -> layout /// Debug layout for an implementation file - val implFileL : TypedImplFile -> layout + val implFileL : TcGlobals -> TypedImplFile -> layout /// Debug layout for a list of implementation files - val implFilesL : TypedImplFile list -> layout + val implFilesL : TcGlobals -> TypedImplFile list -> layout /// Debug layout for class and record fields val recdFieldRefL : RecdFieldRef -> layout diff --git a/src/fsharp/TastPickle.fsi b/src/fsharp/TastPickle.fsi index 9f1000580ae..2b659b0598d 100644 --- a/src/fsharp/TastPickle.fsi +++ b/src/fsharp/TastPickle.fsi @@ -142,7 +142,7 @@ val internal u_ty : unpickler val internal unpickleCcuInfo : ReaderState -> PickledCcuInfo /// Deserialize an arbitrary object which may have holes referring to other compilation units -val internal unpickleObjWithDanglingCcus : file:string -> viewedScope:ILScopeRef -> ilModule:ILModuleDef option -> ('T unpickler) -> byte[] -> PickledDataWithReferences<'T> +val internal unpickleObjWithDanglingCcus : file:string -> viewedScope:ILScopeRef -> ilModule:ILModuleDef option -> ('T unpickler) -> byte[] -> PickledDataWithReferences<'T> diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index 337205632e3..1aa14c5794d 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -652,13 +652,13 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let v_hash_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "hash" , None , Some "Hash" , [vara], ([[varaTy]], v_int_ty)) let v_box_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "box" , None , Some "Box" , [vara], ([[varaTy]], v_obj_ty)) let v_isnull_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "isNull" , None , Some "IsNull" , [vara], ([[varaTy]], v_bool_ty)) - let v_isnotnull_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "isNotNull" , None , Some "IsNotNull" , [vara], ([[varaTy]], v_bool_ty)) + let v_isnotnull_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "isNotNull" , None , Some "IsNotNull" , [vara], ([[varaTy]], v_bool_ty)) let v_raise_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "raise" , None , Some "Raise" , [vara], ([[mkSysNonGenericTy sys "Exception"]], varaTy)) - let v_failwith_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "failwith" , None , Some "FailWith" , [vara], ([[v_string_ty]], varaTy)) - let v_invalid_arg_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "invalidArg" , None , Some "InvalidArg" , [vara], ([[v_string_ty]; [v_string_ty]], varaTy)) - let v_null_arg_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "nullArg" , None , Some "NullArg" , [vara], ([[v_string_ty]], varaTy)) - let v_invalid_op_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "invalidOp" , None , Some "InvalidOp" , [vara], ([[v_string_ty]], varaTy)) - let v_failwithf_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "failwithf" , None, Some "PrintFormatToStringThenFail" , [vara;varb], ([[mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty]], varaTy)) + let v_failwith_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "failwith" , None , Some "FailWith" , [vara], ([[v_string_ty]], varaTy)) + let v_invalid_arg_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "invalidArg" , None , Some "InvalidArg" , [vara], ([[v_string_ty]; [v_string_ty]], varaTy)) + let v_null_arg_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "nullArg" , None , Some "NullArg" , [vara], ([[v_string_ty]], varaTy)) + let v_invalid_op_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "invalidOp" , None , Some "InvalidOp" , [vara], ([[v_string_ty]], varaTy)) + let v_failwithf_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "failwithf" , None , Some "PrintFormatToStringThenFail" , [vara;varb], ([[mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty]], varaTy)) let v_reraise_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "reraise" , None , Some "Reraise", [vara], ([[v_unit_ty]], varaTy)) let v_typeof_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "typeof" , None , Some "TypeOf" , [vara], ([], v_system_Type_ty)) @@ -697,9 +697,7 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let v_seq_empty_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "empty" , None , Some "Empty" , [vara], ([], mkSeqTy varaTy)) let v_new_format_info = makeIntrinsicValRef(fslib_MFCore_nleref, ".ctor" , Some "PrintfFormat`5", None , [vara;varb;varc;vard;vare], ([[v_string_ty]], mkPrintfFormatTy varaTy varbTy varcTy vardTy vareTy)) let v_sprintf_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "sprintf" , None , Some "PrintFormatToStringThen", [vara], ([[mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty]], varaTy)) - let v_lazy_force_info = - // Lazy\Value for > 4.0 - makeIntrinsicValRef(fslib_MFLazyExtensions_nleref, "Force" , Some "Lazy`1" , None , [vara], ([[mkLazyTy varaTy]; []], varaTy)) + let v_lazy_force_info = makeIntrinsicValRef(fslib_MFLazyExtensions_nleref, "Force" , Some "Lazy`1" , None , [vara], ([[mkLazyTy varaTy]; []], varaTy)) let v_lazy_create_info = makeIntrinsicValRef(fslib_MFLazyExtensions_nleref, "Create" , Some "Lazy`1" , None , [vara], ([[v_unit_ty --> varaTy]], mkLazyTy varaTy)) let v_seq_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "seq" , None , Some "CreateSequence" , [vara], ([[mkSeqTy varaTy]], mkSeqTy varaTy)) @@ -737,6 +735,7 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let mutable debuggerBrowsableNeverAttributeCache = None let mkDebuggerNonUserCodeAttribute() = mkILCustomAttribute ilg (findSysILTypeRef tname_DebuggerNonUserCodeAttribute, [], [], []) let mkCompilerGeneratedAttribute () = mkILCustomAttribute ilg (tref_CompilerGeneratedAttribute, [], [], []) + let compilerGlobalState = CompilerGlobalState() // Requests attributes to be added to compiler generated methods. let addGeneratedAttrs (attrs: ILAttributes) = @@ -1475,17 +1474,17 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d (if enableEnC then 4 else 0) let tref_DebuggableAttribute_DebuggingModes = mkILTyRefInTyRef (tref_DebuggableAttribute, tname_DebuggableAttribute_DebuggingModes) mkILCustomAttribute ilg - (tref_DebuggableAttribute, [mkILNonGenericValueTy tref_DebuggableAttribute_DebuggingModes], + (tref_DebuggableAttribute, [mkILNonGenericValueTy tref_DebuggableAttribute_DebuggingModes], (* See System.Diagnostics.DebuggableAttribute.DebuggingModes *) [ILAttribElem.Int32( debuggingMode )], []) - member __.CompilerGeneratedAttribute = mkCompilerGeneratedAttribute () - - member __.eraseClassUnionDef = EraseUnions.mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addPropertyNeverAttrs, addFieldGeneratedAttrs, addFieldNeverAttrs, mkDebuggerTypeProxyAttribute) ilg + member internal __.CompilerGlobalState = Some compilerGlobalState + + member __.CompilerGeneratedAttribute = mkCompilerGeneratedAttribute () + member __.eraseClassUnionDef = EraseUnions.mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addPropertyNeverAttrs, addFieldGeneratedAttrs, addFieldNeverAttrs, mkDebuggerTypeProxyAttribute) ilg #if DEBUG // This global is only used during debug output let global_g = ref (None : TcGlobals option) #endif - diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 66267dbe148..485b367aed4 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -1559,7 +1559,10 @@ let InstanceMembersNeedSafeInitCheck cenv m thisTy = thisTy let MakeSafeInitField (g: TcGlobals) env m isStatic = - let id = ident(globalNng.FreshCompilerGeneratedName("init", m), m) + let id = + // Ensure that we have an g.CompilerGlobalState + assert(g.CompilerGlobalState |> Option.isSome) + ident(g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName("init", m), m) let taccess = TAccess [env.eAccessPath] NewRecdField isStatic None id false g.int_ty true true [] [] XmlDoc.Empty taccess true @@ -3436,7 +3439,7 @@ let ConvertArbitraryExprToEnumerable cenv ty (env: TcEnv) (expr: Expr) = let expr = mkCompGenLet m enumerableVar expr - (mkCallSeqOfFunctions cenv.g m retTypeOfGetEnumerator enumElemTy + (mkCallSeqOfFunctions cenv.g m retTypeOfGetEnumerator enumElemTy (mkUnitDelayLambda cenv.g m getEnumExpr) (mkLambda m enumeratorVar (guardExpr, guardTy)) (mkLambda m enumeratorVar (betterCurrentExpr, enumElemTy))) @@ -7241,7 +7244,7 @@ and TcForEachExpr cenv overallTy env tpenv (pat, enumSynExpr, bodySynExpr, mWhol let elemAddrTy = if isReadOnlySpan then mkInByrefTy cenv.g elemTy else mkByrefTy cenv.g elemTy // Evaluate the span index lookup - let bodyExprFixup elemVar bodyExpr = + let bodyExprFixup elemVar bodyExpr = let elemAddrVar, _ = mkCompGenLocal mForLoopStart "addr" elemAddrTy let e = mkCompGenLet mForLoopStart elemVar (mkAddrGet mForLoopStart (mkLocalValRef elemAddrVar)) bodyExpr let getItemCallExpr, _ = BuildMethodCall tcVal cenv.g cenv.amap PossiblyMutates mWholeExpr true getItemMethInfo ValUseFlag.NormalValUse [] [ spanExpr ] [ idxExpr ] @@ -7251,7 +7254,7 @@ and TcForEachExpr cenv overallTy env tpenv (pat, enumSynExpr, bodySynExpr, mWhol let overallExprFixup overallExpr = mkCompGenLet mForLoopStart spanVar enumExpr overallExpr let getLengthCallExpr, _ = BuildMethodCall tcVal cenv.g cenv.amap PossiblyMutates mWholeExpr true getLengthMethInfo ValUseFlag.NormalValUse [] [ spanExpr ] [] - + // Ask for a loop over integers for the given range (elemTy, bodyExprFixup, overallExprFixup, Choice2Of3 (idxVar, mkZero cenv.g mForLoopStart, mkDecr cenv.g mForLoopStart getLengthCallExpr)) @@ -13311,7 +13314,7 @@ module IncrClassChecking = let takenFieldNames = [ for b in memberBinds do - yield b.Var.CompiledName + yield b.Var.CompiledName cenv.g.CompilerGlobalState yield b.Var.DisplayName yield b.Var.CoreDisplayName yield b.Var.LogicalName ] diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index 09e46ba3386..94f40226214 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -2456,74 +2456,6 @@ module LexbufLocalXmlDocStore = | _ -> PreXmlDoc.Empty - - -/// Generates compiler-generated names. Each name generated also includes the StartLine number of the range passed in -/// at the point of first generation. -/// -/// This type may be accessed concurrently, though in practice it is only used from the compilation thread. -/// It is made concurrency-safe since a global instance of the type is allocated in tast.fs, and it is good -/// policy to make all globally-allocated objects concurrency safe in case future versions of the compiler -/// are used to host multiple concurrent instances of compilation. -type NiceNameGenerator() = - - let lockObj = obj() - let basicNameCounts = new Dictionary(100) - - member x.FreshCompilerGeneratedName (name, m: range) = - lock lockObj (fun () -> - let basicName = GetBasicNameOfPossibleCompilerGeneratedName name - let n = - match basicNameCounts.TryGetValue basicName with - | true, count -> count - | _ -> 0 - let nm = CompilerGeneratedNameSuffix basicName (string m.StartLine + (match n with 0 -> "" | n -> "-" + string n)) - basicNameCounts.[basicName] <- n + 1 - nm) - - member x.Reset () = - lock lockObj (fun () -> - basicNameCounts.Clear() - ) - - - -/// Generates compiler-generated names marked up with a source code location, but if given the same unique value then -/// return precisely the same name. Each name generated also includes the StartLine number of the range passed in -/// at the point of first generation. -/// -/// This type may be accessed concurrently, though in practice it is only used from the compilation thread. -/// It is made concurrency-safe since a global instance of the type is allocated in tast.fs. -type StableNiceNameGenerator() = - - let lockObj = obj() - - let names = new Dictionary<(string * int64), string>(100) - let basicNameCounts = new Dictionary(100) - - member x.GetUniqueCompilerGeneratedName (name, m: range, uniq) = - lock lockObj (fun () -> - let basicName = GetBasicNameOfPossibleCompilerGeneratedName name - let key = basicName, uniq - match names.TryGetValue key with - | true, nm -> nm - | _ -> - let n = - match basicNameCounts.TryGetValue basicName with - | true, c -> c - | _ -> 0 - let nm = CompilerGeneratedNameSuffix basicName (string m.StartLine + (match n with 0 -> "" | n -> "-" + string n)) - names.[key] <- nm - basicNameCounts.[basicName] <- n + 1 - nm - ) - - member x.Reset () = - lock lockObj (fun () -> - basicNameCounts.Clear() - names.Clear() - ) - let rec synExprContainsError inpExpr = let rec walkBind (Binding(_, _, _, _, _, _, _, _, _, synExpr, _, _)) = walkExpr synExpr and walkExprs es = es |> List.exists walkExpr diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index 4660b2e4817..aa1a55f9492 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -953,13 +953,14 @@ type internal FsiDynamicCompiler outWriter: TextWriter, tcImports: TcImports, tcGlobals: TcGlobals, - ilGlobals: ILGlobals, fsiOptions : FsiCommandLineOptions, fsiConsoleOutput : FsiConsoleOutput, fsiCollectible: bool, niceNameGen, resolveAssemblyRef) = + let ilGlobals = tcGlobals.ilg + let outfile = "TMPFSCI.exe" let assemblyName = "FSI-ASSEMBLY" @@ -2512,8 +2513,6 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i with e -> stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e - let ilGlobals = tcGlobals.ilg - let niceNameGen = NiceNameGenerator() // Share intern'd strings across all lexing/parsing @@ -2534,21 +2533,21 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i match tcImports.TryFindExistingFullyQualifiedPathByExactAssemblyRef (ctok, aref) with | Some resolvedPath -> Some (Choice1Of2 resolvedPath) | None -> None - - let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, ilGlobals, fsiOptions, fsiConsoleOutput, fsiCollectible, niceNameGen, resolveAssemblyRef) - - let fsiInterruptController = FsiInterruptController(fsiOptions, fsiConsoleOutput) - + + let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, fsiOptions, fsiConsoleOutput, fsiCollectible, niceNameGen, resolveAssemblyRef) + + let fsiInterruptController = FsiInterruptController(fsiOptions, fsiConsoleOutput) + let uninstallMagicAssemblyResolution = MagicAssemblyResolution.Install(tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput) - - /// This reference cell holds the most recent interactive state + + /// This reference cell holds the most recent interactive state let initialInteractiveState = fsiDynamicCompiler.GetInitialInteractiveState () let fsiStdinLexerProvider = FsiStdinLexerProvider(tcConfigB, fsiStdinSyphon, fsiConsoleInput, fsiConsoleOutput, fsiOptions, lexResourceManager) let fsiInteractionProcessor = FsiInteractionProcessor(fsi, tcConfigB, fsiOptions, fsiDynamicCompiler, fsiConsolePrompt, fsiConsoleOutput, fsiInterruptController, fsiStdinLexerProvider, lexResourceManager, initialInteractiveState) - let commitResult res = + let commitResult res = match res with | Choice1Of2 r -> r | Choice2Of2 None -> failwith "Operation failed. The error text has been printed in the error stream. To return the corresponding FSharpErrorInfo use the EvalInteractionNonThrowing, EvalScriptNonThrowing or EvalExpressionNonThrowing" diff --git a/src/fsharp/service/IncrementalBuild.fs b/src/fsharp/service/IncrementalBuild.fs index 69d416f9921..24769360aeb 100755 --- a/src/fsharp/service/IncrementalBuild.fs +++ b/src/fsharp/service/IncrementalBuild.fs @@ -1206,7 +1206,7 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, tcState: /// Manages an incremental build graph for the build of a single F# project type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInputs, nonFrameworkResolutions, unresolvedReferences, tcConfig: TcConfig, projectDirectory, outfile, - assemblyName, niceNameGen: Ast.NiceNameGenerator, lexResourceManager, + assemblyName, niceNameGen: NiceNameGenerator, lexResourceManager, sourceFiles, loadClosureOpt: LoadClosure option, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) = diff --git a/src/fsharp/service/ServiceDeclarationLists.fs b/src/fsharp/service/ServiceDeclarationLists.fs index b706a3835a9..f06fc56ca2e 100644 --- a/src/fsharp/service/ServiceDeclarationLists.fs +++ b/src/fsharp/service/ServiceDeclarationLists.fs @@ -630,7 +630,7 @@ type FSharpDeclarationListInfo(declarations: FSharpDeclarationListItem[], isForT let isActivePatternItem (items: CompletionItem list) = match items |> List.map (fun x -> x.Item) with - | [Item.Value vref] -> IsActivePatternName vref.CompiledName + | [Item.Value vref] -> IsActivePatternName (vref.CompiledName infoReader.g.CompilerGlobalState) | _ -> false items |> List.filter (fun (displayName, items) -> diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index e09e1d4df30..7941a6be577 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -915,7 +915,7 @@ module FSharpExprConvert = let ccu = nlr.EnclosingEntity.nlr.Ccu let vName = nlr.ItemKey.PartialKey.LogicalName // this is actually compiled name let findByName = - enclosingEntity.MembersOfFSharpTyconSorted |> List.filter (fun v -> v.CompiledName = vName) + enclosingEntity.MembersOfFSharpTyconSorted |> List.filter (fun v -> (v.CompiledName cenv.g.CompilerGlobalState) = vName) match findByName with | [v] -> makeFSCall isMember v @@ -925,7 +925,7 @@ module FSharpExprConvert = let findModuleMemberByName = enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers |> Seq.filter (fun v -> - v.CompiledName = vName && + (v.CompiledName cenv.g.CompilerGlobalState) = vName && match v.DeclaringEntity with | Parent p -> p.PublicPath = enclosingEntity.PublicPath | _ -> false @@ -941,7 +941,7 @@ module FSharpExprConvert = let name = PrettyNaming.ChopPropertyName vName let findByName = enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers - |> Seq.filter (fun v -> v.CompiledName = name) + |> Seq.filter (fun v -> (v.CompiledName cenv.g.CompilerGlobalState) = name) |> List.ofSeq match findByName with | [ v ] -> @@ -989,14 +989,14 @@ module FSharpExprConvert = match subClass with | Some name -> let ucref = UCRef(tcref, name) - let mkR = ConvUnionCaseRef cenv ucref + let mkR = ConvUnionCaseRef cenv ucref let objR = ConvLValueExpr cenv env callArgs.Head let projR = FSharpField(cenv, ucref, ucref.Index) E.UnionCaseGet(objR, typR, mkR, projR) | _ -> failwith "Failed to recognize union type member" else - let names = enclosingEntity.MembersOfFSharpTyconSorted |> List.map (fun v -> v.CompiledName) |> String.concat ", " + let names = enclosingEntity.MembersOfFSharpTyconSorted |> List.map (fun v -> v.CompiledName cenv.g.CompilerGlobalState) |> String.concat ", " failwithf "Member '%s' not found in type %s, found: %s" vName enclosingEntity.DisplayName names | _ -> // member is overloaded match nlr.ItemKey.TypeForLinkage with diff --git a/src/fsharp/symbols/SymbolHelpers.fs b/src/fsharp/symbols/SymbolHelpers.fs index 0547f759df2..1440eef5a4c 100644 --- a/src/fsharp/symbols/SymbolHelpers.fs +++ b/src/fsharp/symbols/SymbolHelpers.fs @@ -1302,14 +1302,14 @@ module internal SymbolHelpers = #endif /// Get the "F1 Keyword" associated with an item, for looking up documentatio help indexes on the web - let rec GetF1Keyword g item = + let rec GetF1Keyword (g: TcGlobals) item = let getKeywordForMethInfo (minfo : MethInfo) = match minfo with | FSMeth(_, _, vref, _) -> match vref.DeclaringEntity with | Parent tcref -> - (tcref |> ticksAndArgCountTextOfTyconRef)+"."+vref.CompiledName|> Some + (tcref |> ticksAndArgCountTextOfTyconRef) + "." + vref.CompiledName g.CompilerGlobalState |> Some | ParentNone -> None | ILMeth (_, minfo, _) -> @@ -1334,25 +1334,25 @@ module internal SymbolHelpers = | [] -> "" | l -> "``"+(List.length l).ToString() - sprintf "%s.%s%s" (tyconRef |> ticksAndArgCountTextOfTyconRef) v.CompiledName paramsString |> Some + sprintf "%s.%s%s" (tyconRef |> ticksAndArgCountTextOfTyconRef) (v.CompiledName g.CompilerGlobalState) paramsString |> Some else None - | Item.ActivePatternCase apref -> + | Item.ActivePatternCase apref -> GetF1Keyword g (Item.Value apref.ActivePatternVal) - | Item.UnionCase(ucinfo, _) -> - (ucinfo.TyconRef |> ticksAndArgCountTextOfTyconRef)+"."+ucinfo.Name |> Some + | Item.UnionCase(ucinfo, _) -> + (ucinfo.TyconRef |> ticksAndArgCountTextOfTyconRef) + "."+ucinfo.Name |> Some - | Item.RecdField rfi -> - (rfi.TyconRef |> ticksAndArgCountTextOfTyconRef)+"."+rfi.Name |> Some + | Item.RecdField rfi -> + (rfi.TyconRef |> ticksAndArgCountTextOfTyconRef) + "." + rfi.Name |> Some - | Item.AnonRecdField _ -> None + | Item.AnonRecdField _ -> None - | Item.ILField finfo -> + | Item.ILField finfo -> match finfo with | ILFieldInfo(tinfo, fdef) -> - (tinfo.TyconRefOfRawMetadata |> ticksAndArgCountTextOfTyconRef)+"."+fdef.Name |> Some + (tinfo.TyconRefOfRawMetadata |> ticksAndArgCountTextOfTyconRef) + "." + fdef.Name |> Some #if !NO_EXTENSIONTYPING | ProvidedField _ -> None #endif diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 50368c3ca2f..afc2f2e4b22 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -814,12 +814,11 @@ and FSharpUnionCase(cenv, v: UnionCaseRef) = match other with | :? FSharpUnionCase as uc -> v === uc.V | _ -> false - + override x.GetHashCode() = hash v.CaseName override x.ToString() = x.CompiledName - and FSharpFieldData = | AnonField of AnonRecdTypeInfo * TTypes * int * range | ILField of ILFieldInfo @@ -1740,7 +1739,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = member x.CompiledName = checkIsResolved() match fsharpInfo() with - | Some v -> v.CompiledName + | Some v -> v.CompiledName cenv.g.CompilerGlobalState | None -> x.LogicalName member __.LogicalName = @@ -2007,7 +2006,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = override x.ToString() = try let prefix = (if x.IsEvent then "event " elif x.IsProperty then "property " elif x.IsMember then "member " else "val ") - prefix + x.LogicalName + prefix + x.LogicalName with _ -> "??" member x.FormatLayout (denv:FSharpDisplayContext) = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 98a8710afb0..dd8f0506f70 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -44,14 +44,6 @@ type Stamp = int64 //++GLOBAL MUTABLE STATE (concurrency-safe) let newStamp = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment i -/// A global generator of compiler generated names -// ++GLOBAL MUTABLE STATE (concurrency safe by locking inside NiceNameGenerator) -let globalNng = NiceNameGenerator() - -/// A global generator of stable compiler generated names -// ++GLOBAL MUTABLE STATE (concurrency safe by locking inside StableNiceNameGenerator) -let globalStableNameGenerator = StableNiceNameGenerator () - type StampMap<'T> = Map //------------------------------------------------------------------------- @@ -2543,8 +2535,7 @@ and and ValData = Val and [] Val = - { - /// Mutable for unpickle linkage + { /// Mutable for unpickle linkage mutable val_logical_name: string /// Mutable for unpickle linkage @@ -2555,12 +2546,12 @@ and [] /// Mutable for unpickle linkage mutable val_stamp: Stamp - /// See vflags section further below for encoding/decodings here + /// See vflags section further below for encoding/decodings here mutable val_flags: ValFlags - - mutable val_opt_data: ValOptionalData option } - static member NewEmptyValOptData() = + mutable val_opt_data: ValOptionalData option } + + static member NewEmptyValOptData() = { val_compiled_name = None val_other_range = None val_const = None @@ -2888,7 +2879,7 @@ and [] /// - If this is an implementation of an abstract slot then this may be a mangled name /// - If this is an extension member then this will be a mangled name /// - If this is an operator then this is 'op_Addition' - member x.CompiledName = + member x.CompiledName (compilerGlobalState:CompilerGlobalState option) = let givenName = match x.val_opt_data with | Some { val_compiled_name = Some n } -> n @@ -2907,10 +2898,10 @@ and [] // let dt = System.DateTime.Now - System.DateTime.Now // IsMemberOrModuleBinding = false, IsCompiledAsTopLevel = true, IsMember = false, CompilerGenerated=true // // However we don't need this for CompilerGenerated members such as the implementations of IComparable - if x.IsCompiledAsTopLevel && not x.IsMember && (x.IsCompilerGenerated || not x.IsMemberOrModuleBinding) then - globalStableNameGenerator.GetUniqueCompilerGeneratedName(givenName, x.Range, x.Stamp) - else - givenName + match compilerGlobalState with + | Some state when x.IsCompiledAsTopLevel && not x.IsMember && (x.IsCompilerGenerated || not x.IsMemberOrModuleBinding) -> + state.StableNameGenerator.GetUniqueCompilerGeneratedName(givenName, x.Range, x.Stamp) + | _ -> givenName /// The name of the property. /// - If this is a property then this is 'Foo' @@ -4561,7 +4552,7 @@ and [] member x.DebugText = x.ToString() - override x.ToString() = sprintf "TBind(%s, ...)" x.Var.CompiledName + override x.ToString() = sprintf "TBind(%s, ...)" (x.Var.CompiledName None) /// Represents a reference to an active pattern element. The /// integer indicates which choice in the target set is being selected by this item. @@ -5764,16 +5755,16 @@ let NewVal (logicalName: string, m: range, compiledName, ty, isMutable, isCompGen, arity, access, recValInfo, specialRepr, baseOrThis, attribs, inlineInfo, doc, isModuleOrMemberBinding, isExtensionMember, isIncrClassSpecialMember, isTyFunc, allowTypeInst, isGeneratedEventVal, - konst, actualParent) : Val = + konst, actualParent) : Val = let stamp = newStamp() - Val.New - { val_stamp = stamp - val_logical_name = logicalName - val_range = m - val_flags = ValFlags(recValInfo, baseOrThis, isCompGen, inlineInfo, isMutable, isModuleOrMemberBinding, isExtensionMember, isIncrClassSpecialMember, isTyFunc, allowTypeInst, isGeneratedEventVal) - val_type = ty - val_opt_data = + Val.New { + val_stamp = stamp + val_logical_name = logicalName + val_range = m + val_flags = ValFlags(recValInfo, baseOrThis, isCompGen, inlineInfo, isMutable, isModuleOrMemberBinding, isExtensionMember, isIncrClassSpecialMember, isTyFunc, allowTypeInst, isGeneratedEventVal) + val_type = ty + val_opt_data = match compiledName, arity, konst, access, doc, specialRepr, actualParent, attribs with | None, None, None, TAccess [], XmlDoc [||], None, ParentNone, [] -> None | _ -> @@ -5788,11 +5779,9 @@ let NewVal val_attribs = attribs } } - /// Create the new contents of an overall assembly let NewCcuContents sref m nm mty = NewModuleOrNamespace (Some(CompPath(sref, []))) taccessPublic (ident(nm, m)) XmlDoc.Empty [] (MaybeLazy.Strict mty) - //-------------------------------------------------------------------------- // Cloning and adjusting diff --git a/tests/fsharpqa/Source/Optimizations/Inlining/env.lst b/tests/fsharpqa/Source/Optimizations/Inlining/env.lst index 9e92d0998cd..9c95c7c6545 100644 --- a/tests/fsharpqa/Source/Optimizations/Inlining/env.lst +++ b/tests/fsharpqa/Source/Optimizations/Inlining/env.lst @@ -1,4 +1,3 @@ -# flaky test: https://github.com/Microsoft/visualfsharp/issues/6657 -#NoMT SOURCE=Match01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match01.dll" # Match01.fs +NoMT SOURCE=Match01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match01.dll" # Match01.fs NoMT SOURCE=Match02.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match02.dll" # Match02.fs NoMT SOURCE=StructUnion01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd StructUnion01.dll" # StructUnion01.fs