diff --git a/azure-pipelines.yml b/azure-pipelines.yml index d2590b5ba6c..0e658575eab 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -217,6 +217,13 @@ stages: name: $(DncEngPublicBuildPool) demands: ImageOverride -equals $(WindowsMachineQueueName) timeoutInMinutes: 90 + strategy: + maxParallel: 2 + matrix: + regular: + _experimental_flag: null + experimental_features: + _experimental_flag: 1 steps: - checkout: self clean: true @@ -229,6 +236,8 @@ stages: workingDirectory: $(Build.SourcesDirectory) installationPath: $(Build.SourcesDirectory)/.dotnet - script: .\eng\test-determinism.cmd -configuration Debug + env: + FSHARP_EXPERIMENTAL_FEATURES: $(_experimental_flag) displayName: Determinism tests with Debug configuration - task: PublishPipelineArtifact@1 displayName: Publish Determinism Logs @@ -492,11 +501,22 @@ stages: pool: name: $(DncEngPublicBuildPool) demands: ImageOverride -equals $(WindowsMachineQueueName) + strategy: + maxParallel: 2 + matrix: + regular: + _experimental_flag: null + experimental_features: + _experimental_flag: 1 steps: - checkout: self clean: true - script: .\Build.cmd -c Release -pack + env: + FSHARP_EXPERIMENTAL_FEATURES: $(_experimental_flag) - script: .\tests\EndToEndBuildTests\EndToEndBuildTests.cmd -c Release + env: + FSHARP_EXPERIMENTAL_FEATURES: $(_experimental_flag) displayName: End to end build tests # Up-to-date - disabled due to it being flaky @@ -512,35 +532,8 @@ stages: # filePath: eng\tests\UpToDate.ps1 # arguments: -configuration $(_BuildConfig) -ci -binaryLog - # Run Build with --test:ParallelCheckingWithSignatureFilesOn - - job: ParallelCheckingWithSignatureFiles - condition: eq(variables['Build.Reason'], 'PullRequest') - variables: - - name: _SignType - value: Test - pool: - name: $(DncEngPublicBuildPool) - demands: ImageOverride -equals $(WindowsMachineQueueName) - timeoutInMinutes: 90 - steps: - - checkout: self - clean: true - - task: UseDotNet@2 - displayName: install SDK - inputs: - packageType: sdk - useGlobalJson: true - includePreviewVersions: false - workingDirectory: $(Build.SourcesDirectory) - installationPath: $(Build.SourcesDirectory)/.dotnet - - script: .\build.cmd -c Release -binaryLog /p:ParallelCheckingWithSignatureFilesOn=true - displayName: ParallelCheckingWithSignatureFiles build with Debug configuration - - task: PublishPipelineArtifact@1 - displayName: Publish ParallelCheckingWithSignatureFiles Logs - inputs: - targetPath: '$(Build.SourcesDirectory)/artifacts/log/Release' - artifactName: 'ParallelCheckingWithSignatureFiles Attempt $(System.JobAttempt) Logs' - continueOnError: true + # Run Build with Fsharp Experimental Features + # Possible change: --times:$(Build.SourcesDirectory)/artifacts/log/Release/compiler_timing.csv # Plain build Windows - job: Plain_Build_Windows diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index e2cca7d1809..a907da79373 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -3902,7 +3902,7 @@ let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) = // If there is a sequence point as the first instruction then keep it at the front | I_seqpoint _ as i0 -> let labels = - let dict = Dictionary.newWithSize c2.Labels.Count + let dict = Dictionary.newWithSize (c2.Labels.Count * 2) // Decrease chance of collisions by oversizing the hashtable for kvp in c2.Labels do dict.Add(kvp.Key, (if kvp.Value = 0 then 0 else kvp.Value + n)) @@ -3915,7 +3915,7 @@ let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) = } | _ -> let labels = - let dict = Dictionary.newWithSize c2.Labels.Count + let dict = Dictionary.newWithSize (c2.Labels.Count * 2) // Decrease chance of collisions by oversizing the hashtable for kvp in c2.Labels do dict.Add(kvp.Key, kvp.Value + n) diff --git a/src/Compiler/AbstractIL/ilmorph.fs b/src/Compiler/AbstractIL/ilmorph.fs index dad1e16369d..2ab4171781a 100644 --- a/src/Compiler/AbstractIL/ilmorph.fs +++ b/src/Compiler/AbstractIL/ilmorph.fs @@ -37,7 +37,7 @@ let code_instr2instrs f (code: ILCode) = adjust[old] <- nw let labels = - let dict = Dictionary.newWithSize code.Labels.Count + let dict = Dictionary.newWithSize (code.Labels.Count * 2) // Decrease chance of collisions by oversizing the hashtable for kvp in code.Labels do dict.Add(kvp.Key, adjust[kvp.Value]) diff --git a/src/Compiler/Checking/AttributeChecking.fs b/src/Compiler/Checking/AttributeChecking.fs index de1aadfc803..087ebc1e0b1 100644 --- a/src/Compiler/Checking/AttributeChecking.fs +++ b/src/Compiler/Checking/AttributeChecking.fs @@ -522,7 +522,7 @@ let CheckRecdFieldInfoAttributes g (x:RecdFieldInfo) m = CheckRecdFieldAttributes g x.RecdFieldRef m // Identify any security attributes -let IsSecurityAttribute (g: TcGlobals) amap (casmap : Dictionary) (Attrib(tcref, _, _, _, _, _, _)) m = +let IsSecurityAttribute (g: TcGlobals) amap (casmap : IDictionary) (Attrib(tcref, _, _, _, _, _, _)) m = // There's no CAS on Silverlight, so we have to be careful here match g.attrib_SecurityAttribute with | None -> false @@ -533,7 +533,7 @@ let IsSecurityAttribute (g: TcGlobals) amap (casmap : Dictionary) ( match casmap.TryGetValue tcs with | true, c -> c | _ -> - let exists = ExistsInEntireHierarchyOfType (fun t -> typeEquiv g t (mkAppTy attr.TyconRef [])) g amap m AllowMultiIntfInstantiations.Yes (mkAppTy tcref []) + let exists = ExistsInEntireHierarchyOfType (fun t -> typeEquiv g t (mkAppTy attr.TyconRef [])) g amap m AllowMultiIntfInstantiations.Yes (mkAppTy tcref []) casmap[tcs] <- exists exists | ValueNone -> false diff --git a/src/Compiler/Checking/AttributeChecking.fsi b/src/Compiler/Checking/AttributeChecking.fsi index 622864eff4e..b4a608ef1d1 100644 --- a/src/Compiler/Checking/AttributeChecking.fsi +++ b/src/Compiler/Checking/AttributeChecking.fsi @@ -96,7 +96,7 @@ val CheckValAttributes: g: TcGlobals -> x: ValRef -> m: range -> OperationResult val CheckRecdFieldInfoAttributes: g: TcGlobals -> x: RecdFieldInfo -> m: range -> OperationResult val IsSecurityAttribute: - g: TcGlobals -> amap: Import.ImportMap -> casmap: Dictionary -> Attrib -> m: range -> bool + g: TcGlobals -> amap: Import.ImportMap -> casmap: IDictionary -> Attrib -> m: range -> bool val IsSecurityCriticalAttribute: g: TcGlobals -> Attrib -> bool diff --git a/src/Compiler/Checking/MethodCalls.fs b/src/Compiler/Checking/MethodCalls.fs index c7523e7ba50..870443d32b9 100644 --- a/src/Compiler/Checking/MethodCalls.fs +++ b/src/Compiler/Checking/MethodCalls.fs @@ -1806,9 +1806,9 @@ module ProvidedMethodCalls = expr: Tainted) = let varConv = - // note: using paramVars.Length as assumed initial size, but this might not - // be the optimal value; this wasn't checked before obsoleting Dictionary.ofList - let dict = Dictionary.newWithSize paramVars.Length + // note: Assuming the size based on paramVars + // Doubling to decrease chance of collisions + let dict = Dictionary.newWithSize (paramVars.Length*2) for v, e in Seq.zip (paramVars |> Seq.map (fun x -> x.PUntaint(id, m))) (Option.toList thisArg @ allArgs) do dict.Add(v, (None, e)) dict diff --git a/src/Compiler/Checking/QuotationTranslator.fs b/src/Compiler/Checking/QuotationTranslator.fs index 80c7e52e7bf..063609d0232 100644 --- a/src/Compiler/Checking/QuotationTranslator.fs +++ b/src/Compiler/Checking/QuotationTranslator.fs @@ -22,7 +22,7 @@ open System.Collections.Generic module QP = QuotationPickler -let verboseCReflect = condition "VERBOSE_CREFLECT" +let verboseCReflect = isEnvVarSet "VERBOSE_CREFLECT" [] type IsReflectedDefinition = diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 01edf861376..efb652eb407 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -6,6 +6,8 @@ module internal FSharp.Compiler.IlxGen open System.IO open System.Reflection open System.Collections.Generic +open System.Collections.Concurrent +open System.Threading open FSharp.Compiler.IO open Internal.Utilities @@ -42,6 +44,9 @@ open FSharp.Compiler.TypeRelations let IlxGenStackGuardDepth = StackGuard.GetDepthOption "IlxGen" +let getEmptyStackGuard () = + StackGuard(IlxGenStackGuardDepth, "IlxAssemblyGenerator") + let IsNonErasedTypar (tp: Typar) = not tp.IsErased let DropErasedTypars (tps: Typar list) = tps |> List.filter IsNonErasedTypar @@ -233,7 +238,7 @@ type IlxGenIntraAssemblyInfo = /// only accessible intra-assembly. Across assemblies, taking the address of static mutable module-bound values is not permitted. /// The key to the table is the method ref for the property getter for the value, which is a stable name for the Val's /// that come from both the signature and the implementation. - StaticFieldInfo: Dictionary + StaticFieldInfo: ConcurrentDictionary } /// Helper to make sure we take tailcalls in some situations @@ -293,6 +298,9 @@ type IlxGenOptions = /// Whenever possible, use callvirt instead of call alwaysCallVirt: bool + + /// When set to true, the IlxGen will delay generation of method bodies and generated them later in parallel (parallelized across files) + parallelIlxGenEnabled: bool } /// Compilation environment for compiling a fragment of an assembly @@ -328,11 +336,14 @@ type cenv = intraAssemblyInfo: IlxGenIntraAssemblyInfo /// Cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType - casApplied: Dictionary + casApplied: IDictionary /// Used to apply forced inlining optimizations to witnesses generated late during codegen mutable optimizeDuringCodeGen: bool -> Expr -> Expr + /// Delayed Method Generation - which can later be parallelized across multiple files + delayedGenMethods: Queue unit> + /// Guard the stack and move to a new one if necessary mutable stackGuard: StackGuard @@ -1229,6 +1240,12 @@ and IlxGenEnv = /// Indicates that the .locals init flag should be set on a method and all its nested methods and lambdas initLocals: bool + + /// Delay code gen for files. + delayCodeGen: bool + + /// Collection of code-gen functions where each inner array represents codegen (method bodies) functions for a single file + delayedFileGenReverse: list<(unit -> unit)[]> } override _.ToString() = "" @@ -1493,13 +1510,7 @@ let ComputeFieldSpecForVal match optIntraAssemblyInfo with | None -> generate () - | Some intraAssemblyInfo -> - match intraAssemblyInfo.StaticFieldInfo.TryGetValue ilGetterMethRef with - | true, res -> res - | _ -> - let res = generate () - intraAssemblyInfo.StaticFieldInfo[ ilGetterMethRef ] <- res - res + | Some iai -> iai.StaticFieldInfo.GetOrAdd(ilGetterMethRef, (fun _ -> generate ())) /// 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 @@ -1961,10 +1972,12 @@ type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) = gmethods.Add(mkILClassCtor body) and TypeDefsBuilder() = - let tdefs: HashMultiMap = - HashMultiMap(0, HashIdentity.Structural) + + let tdefs = + ConcurrentDictionary>(HashIdentity.Structural) let mutable countDown = System.Int32.MaxValue + let mutable countUp = -1 member b.Close() = //The order we emit type definitions is not deterministic since it is using the reverse of a range from a hash table. We should use an approximation of source order. @@ -1972,7 +1985,7 @@ and TypeDefsBuilder() = // However, for some tests FSI generated code appears sensitive to the order, especially for nested types. [ - for b, eliminateIfEmpty in HashRangeSorted tdefs do + for _, (b, eliminateIfEmpty) in tdefs.Values |> Seq.collect id |> Seq.sortBy fst do let tdef = b.Close() // Skip the type if it is empty if @@ -1988,7 +2001,7 @@ and TypeDefsBuilder() = member b.FindTypeDefBuilder nm = try - tdefs[nm] |> snd |> fst + tdefs[nm] |> List.head |> snd |> fst with :? KeyNotFoundException -> failwith ("FindTypeDefBuilder: " + nm + " not found") @@ -2001,51 +2014,24 @@ and TypeDefsBuilder() = member b.AddTypeDef(tdef: ILTypeDef, eliminateIfEmpty, addAtEnd, tdefDiscards) = let idx = if addAtEnd then - (countDown <- countDown - 1 - countDown) + Interlocked.Decrement(&countDown) else - tdefs.Count + Interlocked.Increment(&countUp) - tdefs.Add(tdef.Name, (idx, (TypeDefBuilder(tdef, tdefDiscards), eliminateIfEmpty))) + let newVal = idx, (TypeDefBuilder(tdef, tdefDiscards), eliminateIfEmpty) + + tdefs.AddOrUpdate(tdef.Name, [ newVal ], (fun key oldList -> newVal :: oldList)) + |> ignore type AnonTypeGenerationTable() = - // Dictionary is safe here as it will only be used during the codegen stage - will happen on a single thread. let dict = - Dictionary(HashIdentity.Structural) - - member _.Table = dict - -/// Assembly generation buffers -type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf = - let g = cenv.g - // The Abstract IL table of types - let gtdefs = TypeDefsBuilder() + ConcurrentDictionary>(HashIdentity.Structural) - // The definitions of top level values, as quotations. - // Dictionary is safe here as it will only be used during the codegen stage - will happen on a single thread. - let mutable reflectedDefinitions: Dictionary = - Dictionary(HashIdentity.Reference) - - let mutable extraBindingsToGenerate = [] - - // A memoization table for generating value types for big constant arrays - let rawDataValueTypeGenerator = - MemoizationTable( - (fun (cloc, size) -> - let name = - CompilerGeneratedName("T" + string (newUnique ()) + "_" + string size + "Bytes") // Type names ending ...$T_37Bytes - - let vtdef = mkRawDataValueTypeDef g.iltyp_ValueType (name, size, 0us) - let vtref = NestedTypeRefForCompLoc cloc vtdef.Name - let vtspec = mkILTySpec (vtref, []) - let vtdef = vtdef.WithAccess(ComputeTypeAccess vtref true) - mgbuf.AddTypeDef(vtref, vtdef, false, true, None) - vtspec), - keyComparer = HashIdentity.Structural - ) + let extraBindingsToGenerate = ConcurrentStack() - let generateAnonType genToStringMethod (isStruct, ilTypeRef, nms) = + let generateAnonType cenv (mgbuf: AssemblyBuilder) genToStringMethod (isStruct, ilTypeRef, nms) = + let g = cenv.g let propTys = [ for i, nm in Array.indexed nms -> nm, ILType.TypeVar(uint16 i) ] // Note that this alternative below would give the same names as C#, but the generated @@ -2257,30 +2243,81 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu mgbuf.AddTypeDef(ilTypeRef, ilTypeDef, false, true, None) let extraBindings = - [ + [| yield! AugmentWithHashCompare.MakeBindingsForCompareAugmentation g tycon yield! AugmentWithHashCompare.MakeBindingsForCompareWithComparerAugmentation g tycon yield! AugmentWithHashCompare.MakeBindingsForEqualityWithComparerAugmentation g tycon yield! AugmentWithHashCompare.MakeBindingsForEqualsAugmentation g tycon - ] + |] let optimizedExtraBindings = extraBindings - |> List.map (fun (TBind (a, b, c)) -> + |> Array.map (fun (TBind (a, b, c)) -> // Disable method splitting for bindings related to anonymous records TBind(a, cenv.optimizeDuringCodeGen true b, c)) + |> Array.rev - extraBindingsToGenerate <- optimizedExtraBindings @ extraBindingsToGenerate + extraBindingsToGenerate.PushRange(optimizedExtraBindings) (ilCtorRef, ilMethodRefs, ilTy) + member this.GenerateAnonType(cenv, mgbuf, genToStringMethod, anonInfo: AnonRecdTypeInfo) = + let isStruct = evalAnonInfoIsStruct anonInfo + let key = anonInfo.Stamp + + let at = + dict.GetOrAdd(key, lazy (generateAnonType cenv mgbuf genToStringMethod (isStruct, anonInfo.ILTypeRef, anonInfo.SortedNames))) + + at.Force() |> ignore + + member this.LookupAnonType(cenv, mgbuf, genToStringMethod, anonInfo: AnonRecdTypeInfo) = + match dict.TryGetValue anonInfo.Stamp with + | true, res -> res.Value + | _ -> + if anonInfo.ILTypeRef.Scope.IsLocalRef then + failwithf "the anonymous record %A has not been generated in the pre-phase of generating this module" anonInfo.ILTypeRef + + this.GenerateAnonType(cenv, mgbuf, genToStringMethod, anonInfo) + dict[anonInfo.Stamp].Value + + member _.GrabExtraBindingsToGenerate() = + let result = extraBindingsToGenerate.ToArray() + extraBindingsToGenerate.Clear() + result + +/// Assembly generation buffers +and AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf = + let g = cenv.g + // The Abstract IL table of types + let gtdefs = TypeDefsBuilder() + + // The definitions of top level values, as quotations + let reflectedDefinitions = + new StampedDictionary(HashIdentity.Reference) + + // A memoization table for generating value types for big constant arrays + let rawDataValueTypeGenerator = + MemoizationTable( + (fun (cloc, size) -> + let name = + CompilerGeneratedName("T" + string (newUnique ()) + "_" + string size + "Bytes") // Type names ending ...$T_37Bytes + + let vtdef = mkRawDataValueTypeDef g.iltyp_ValueType (name, size, 0us) + let vtref = NestedTypeRefForCompLoc cloc vtdef.Name + let vtspec = mkILTySpec (vtref, []) + let vtdef = vtdef.WithAccess(ComputeTypeAccess vtref true) + mgbuf.AddTypeDef(vtref, vtdef, false, true, None) + vtspec), + keyComparer = HashIdentity.Structural + ) + let mutable explicitEntryPointInfo: ILTypeRef option = None /// static init fields on script modules. - let mutable scriptInitFspecs: (ILFieldSpec * range) list = [] + let scriptInitFspecs = ConcurrentStack() member _.AddScriptInitFieldSpec(fieldSpec, range) = - scriptInitFspecs <- (fieldSpec, range) :: scriptInitFspecs + scriptInitFspecs.Push((fieldSpec, range)) /// This initializes the script in #load and fsc command-line order causing their /// side effects to be executed. @@ -2301,7 +2338,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu [] ) - scriptInitFspecs |> List.iter InitializeCompiledScript + scriptInitFspecs |> Seq.iter InitializeCompiledScript | None -> () member _.GenerateRawDataValueType(cloc, size) = @@ -2312,29 +2349,13 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu rawDataValueTypeGenerator.Apply((cloc, size)) member _.GenerateAnonType(genToStringMethod, anonInfo: AnonRecdTypeInfo) = - let isStruct = evalAnonInfoIsStruct anonInfo - let key = anonInfo.Stamp - - if not (anonTypeTable.Table.ContainsKey key) then - let info = - generateAnonType genToStringMethod (isStruct, anonInfo.ILTypeRef, anonInfo.SortedNames) - - anonTypeTable.Table[ key ] <- info + anonTypeTable.GenerateAnonType(cenv, mgbuf, genToStringMethod, anonInfo) member this.LookupAnonType(genToStringMethod, anonInfo: AnonRecdTypeInfo) = - match anonTypeTable.Table.TryGetValue anonInfo.Stamp with - | true, res -> res - | _ -> - if anonInfo.ILTypeRef.Scope.IsLocalRef then - failwithf "the anonymous record %A has not been generated in the pre-phase of generating this module" anonInfo.ILTypeRef - - this.GenerateAnonType(genToStringMethod, anonInfo) - anonTypeTable.Table[anonInfo.Stamp] + anonTypeTable.LookupAnonType(cenv, mgbuf, genToStringMethod, anonInfo) member _.GrabExtraBindingsToGenerate() = - let result = extraBindingsToGenerate - extraBindingsToGenerate <- [] - result + anonTypeTable.GrabExtraBindingsToGenerate() member _.AddTypeDef(tref: ILTypeRef, tdef, eliminateIfEmpty, addAtEnd, tdefDiscards) = gtdefs @@ -2345,14 +2366,10 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu gtdefs.FindNestedTypeDefBuilder(tref).GetCurrentFields() member _.AddReflectedDefinition(vspec: Val, expr) = - // preserve order by storing index of item - let n = reflectedDefinitions.Count - reflectedDefinitions.Add(vspec, (vspec.CompiledName cenv.g.CompilerGlobalState, n, expr)) + reflectedDefinitions.Add(vspec, (vspec.CompiledName cenv.g.CompilerGlobalState, expr)) member _.ReplaceNameOfReflectedDefinition(vspec, newName) = - match reflectedDefinitions.TryGetValue vspec with - | true, (name, n, expr) when name <> newName -> reflectedDefinitions[vspec] <- (newName, n, expr) - | _ -> () + reflectedDefinitions.UpdateIfExists(vspec, (fun (oldName, expr) -> if newName = oldName then None else Some(newName, expr))) member _.AddMethodDef(tref: ILTypeRef, ilMethodDef) = gtdefs.FindNestedTypeDefBuilder(tref).AddMethodDef(ilMethodDef) @@ -2366,8 +2383,8 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu let instrs = [ yield! - (if condition "NO_ADD_FEEFEE_TO_CCTORS" then [] - elif condition "ADD_SEQPT_TO_CCTORS" then seqpt + (if isEnvVarSet "NO_ADD_FEEFEE_TO_CCTORS" then [] + elif isEnvVarSet "ADD_SEQPT_TO_CCTORS" then seqpt else feefee) // mark start of hidden code yield mkLdcInt32 0 yield mkNormalStsfld fspec @@ -2392,7 +2409,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu // old implementation adds new element to the head of list so result was accumulated in reversed order let orderedReflectedDefinitions = [ - for KeyValue (vspec, (name, n, expr)) in reflectedDefinitions -> n, ((name, vspec), expr) + for (vspec, (n, (name, expr))) in reflectedDefinitions.GetAll() -> n, ((name, vspec), expr) ] |> List.sortBy (fst >> (~-)) // invert the result to get 'order-by-descending' behavior (items in list are 0..* so we don't need to worry about int.MinValue) |> List.map snd @@ -2648,7 +2665,8 @@ type CodeGenBuffer(m: range, mgbuf: AssemblyBuilder, methodName, alreadyUsedArgs i2) let codeLabels = - let dict = Dictionary.newWithSize (codeLabelToPC.Count + codeLabelToCodeLabel.Count) + let dict = + Dictionary.newWithSize ((codeLabelToPC.Count + codeLabelToCodeLabel.Count) * 2) for kvp in codeLabelToPC do dict.Add(kvp.Key, lab2pc 0 kvp.Key) @@ -3109,6 +3127,23 @@ and CodeGenMethodForExpr cenv mgbuf (entryPointInfo, methodName, eenv, alreadyUs code +and DelayCodeGenMethodForExpr cenv mgbuf ((_, _, eenv, _, _, _, _) as args) = + let change3rdOutOf7 (a1, a2, _, a4, a5, a6, a7) newA3 = (a1, a2, newA3, a4, a5, a6, a7) + + if eenv.delayCodeGen then + let cenv = + { cenv with + stackGuard = getEmptyStackGuard () + } + // Once this is lazily-evaluated later, it should not put things in queue. They would not be picked up by anyone. + let newArgs = change3rdOutOf7 args { eenv with delayCodeGen = false } + + let lazyMethodBody = lazy (CodeGenMethodForExpr cenv mgbuf newArgs) + cenv.delayedGenMethods.Enqueue(fun () -> lazyMethodBody.Force() |> ignore) + lazyMethodBody + else + notlazy (CodeGenMethodForExpr cenv mgbuf args) + //-------------------------------------------------------------------------- // Generate sequels //-------------------------------------------------------------------------- @@ -8349,10 +8384,10 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt = cgbuf.mgbuf.AddOrMergePropertyDef(ilGetterMethSpec.MethodRef.DeclaringTypeRef, ilPropDef, m) let ilMethodDef = - let ilCode = - CodeGenMethodForExpr cenv cgbuf.mgbuf ([], ilGetterMethSpec.Name, eenv, 0, None, rhsExpr, Return) + let ilLazyCode = + DelayCodeGenMethodForExpr cenv cgbuf.mgbuf ([], ilGetterMethSpec.Name, eenv, 0, None, rhsExpr, Return) - let ilMethodBody = MethodBody.IL(lazy ilCode) + let ilMethodBody = MethodBody.IL(ilLazyCode) (mkILStaticMethod ([], ilGetterMethSpec.Name, access, [], mkILReturn ilTy, ilMethodBody)) .WithSpecialName @@ -9069,11 +9104,11 @@ and GenMethodForBinding | [ h ] -> Some h | _ -> None - let ilCodeLazy = - CodeGenMethodForExpr cenv mgbuf (tailCallInfo, mspec.Name, eenvForMeth, 0, selfValOpt, bodyExpr, sequel) + let ilLazyCode = + DelayCodeGenMethodForExpr cenv mgbuf (tailCallInfo, mspec.Name, eenvForMeth, 0, selfValOpt, bodyExpr, sequel) // This is the main code generation for most methods - false, MethodBody.IL(notlazy ilCodeLazy), false + false, MethodBody.IL(ilLazyCode), false // Do not generate DllImport attributes into the code - they are implicit from the P/Invoke let attrs = @@ -10277,7 +10312,13 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: Checke AddBindingsForLocalModuleOrNamespaceType allocVal clocCcu eenv signature - eenvafter + let eenvfinal = + { eenvafter with + delayedFileGenReverse = (cenv.delayedGenMethods |> Array.ofSeq) :: eenvafter.delayedFileGenReverse + } + + cenv.delayedGenMethods.Clear() + eenvfinal and GenForceWholeFileInitializationAsPartOfCCtor cenv (mgbuf: AssemblyBuilder) (lazyInitInfo: ResizeArray<_>) tref imports m = // Authoring a .cctor with effects forces the cctor for the 'initialization' module by doing a dummy store & load of a field @@ -11555,18 +11596,19 @@ let CodegenAssembly cenv eenv mgbuf implFiles = | None -> () | Some (firstImplFiles, lastImplFile) -> - // Generate the assembly sequentially, implementation file by implementation file. - // - // NOTE: In theory this could be done in parallel, except for the presence of linear - // state in the AssemblyBuilder let eenv = List.fold (GenImplFile cenv mgbuf None) eenv firstImplFiles let eenv = GenImplFile cenv mgbuf cenv.options.mainMethodInfo eenv lastImplFile + eenv.delayedFileGenReverse + |> Array.ofList + |> Array.rev + |> ArrayParallel.iter (fun genMeths -> genMeths |> Array.iter (fun gen -> gen ())) + // Some constructs generate residue types and bindings. Generate these now. They don't result in any // top-level initialization code. let extraBindings = mgbuf.GrabExtraBindingsToGenerate() //printfn "#extraBindings = %d" extraBindings.Length - if not (isNil extraBindings) then + if extraBindings.Length > 0 then let mexpr = TMDefs [ for b in extraBindings -> TMDefLet(b, range0) ] let _emptyTopInstrs, _emptyTopCode = @@ -11619,6 +11661,8 @@ let GetEmptyIlxGenEnv (g: TcGlobals) ccu = isInLoop = false initLocals = true imports = None + delayCodeGen = true + delayedFileGenReverse = [] } type IlxGenResults = @@ -11631,6 +11675,43 @@ type IlxGenResults = quotationResourceInfo: (ILTypeRef list * byte[]) list } +let private GenerateResourcesForQuotations reflectedDefinitions cenv = + match reflectedDefinitions with + | [] -> [] + | _ -> + let qscope = + QuotationTranslator.QuotationGenerationScope.Create( + cenv.g, + cenv.amap, + cenv.viewCcu, + cenv.tcVal, + QuotationTranslator.IsReflectedDefinition.Yes + ) + + let defns = + reflectedDefinitions + |> List.choose (fun ((methName, v), e) -> + try + let mbaseR, astExpr = + QuotationTranslator.ConvReflectedDefinition qscope methName v e + + Some(mbaseR, astExpr) + with QuotationTranslator.InvalidQuotedTerm e -> + warning e + None) + + let referencedTypeDefs, typeSplices, exprSplices = qscope.Close() + + for _typeSplice, m in typeSplices do + error (InternalError("A free type variable was detected in a reflected definition", m)) + + for _exprSplice, m in exprSplices do + error (Error(FSComp.SR.ilReflectedDefinitionsCannotUseSliceOperator (), m)) + + let defnsResourceBytes = defns |> QuotationPickler.PickleDefns + + [ (referencedTypeDefs, defnsResourceBytes) ] + let GenerateCode (cenv, anonTypeTable, eenv, CheckedAssemblyAfterOptimization implFiles, assemAttribs, moduleAttribs) = use _ = UseBuildPhase BuildPhase.IlxGen @@ -11642,6 +11723,7 @@ let GenerateCode (cenv, anonTypeTable, eenv, CheckedAssemblyAfterOptimization im let eenv = { eenv with cloc = CompLocForFragment cenv.options.fragName cenv.viewCcu + delayCodeGen = cenv.options.parallelIlxGenEnabled } // Generate the PrivateImplementationDetails type @@ -11664,45 +11746,7 @@ let GenerateCode (cenv, anonTypeTable, eenv, CheckedAssemblyAfterOptimization im GenAttrs cenv eenv (assemAttribs |> List.filter (fun a -> not (IsAssemblyVersionAttribute g a))) let tdefs, reflectedDefinitions = mgbuf.Close() - - // Generate the quotations - let quotationResourceInfo = - match reflectedDefinitions with - | [] -> [] - | _ -> - let qscope = - QuotationTranslator.QuotationGenerationScope.Create( - g, - cenv.amap, - cenv.viewCcu, - cenv.tcVal, - QuotationTranslator.IsReflectedDefinition.Yes - ) - - let defns = - reflectedDefinitions - |> List.choose (fun ((methName, v), e) -> - try - let mbaseR, astExpr = - QuotationTranslator.ConvReflectedDefinition qscope methName v e - - Some(mbaseR, astExpr) - with QuotationTranslator.InvalidQuotedTerm e -> - warning e - None) - - let referencedTypeDefs, typeSplices, exprSplices = qscope.Close() - - for _typeSplice, m in typeSplices do - error (InternalError("A free type variable was detected in a reflected definition", m)) - - for _exprSplice, m in exprSplices do - error (Error(FSComp.SR.ilReflectedDefinitionsCannotUseSliceOperator (), m)) - - let defnsResourceBytes = defns |> QuotationPickler.PickleDefns - - [ (referencedTypeDefs, defnsResourceBytes) ] - + let quotationResourceInfo = GenerateResourcesForQuotations reflectedDefinitions cenv let ilNetModuleAttrs = GenAttrs cenv eenv moduleAttribs let casApplied = Dictionary() @@ -11851,14 +11895,12 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai // The incremental state held by the ILX code generator let mutable ilxGenEnv = GetEmptyIlxGenEnv tcGlobals ccu let anonTypeTable = AnonTypeGenerationTable() - // Dictionaries are safe here as they will only be used during the codegen stage - will happen on a single thread. + let intraAssemblyInfo = { - StaticFieldInfo = Dictionary<_, _>(HashIdentity.Structural) + StaticFieldInfo = ConcurrentDictionary<_, _>(HashIdentity.Structural) } - let casApplied = Dictionary() - let cenv = { g = tcGlobals @@ -11874,11 +11916,12 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai ilUnitTy = None namedDebugPointsForInlinedCode = Map.empty amap = amap - casApplied = casApplied + casApplied = ConcurrentDictionary() intraAssemblyInfo = intraAssemblyInfo optionsOpt = None optimizeDuringCodeGen = (fun _flag expr -> expr) - stackGuard = StackGuard(IlxGenStackGuardDepth, "IlxAssemblyGenerator") + stackGuard = getEmptyStackGuard () + delayedGenMethods = Queue() } /// Register a set of referenced assemblies with the ILX code generator diff --git a/src/Compiler/CodeGen/IlxGen.fsi b/src/Compiler/CodeGen/IlxGen.fsi index d68463e9ca7..4658dd0693b 100644 --- a/src/Compiler/CodeGen/IlxGen.fsi +++ b/src/Compiler/CodeGen/IlxGen.fsi @@ -59,6 +59,9 @@ type internal IlxGenOptions = /// Indicates that, whenever possible, use callvirt instead of call alwaysCallVirt: bool + + /// When set to true, the IlxGen will delay generation of method bodies and generate them later in parallel (parallelized across files) + parallelIlxGenEnabled: bool } /// The results of the ILX compilation of one fragment of an assembly diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 54e45ead3cc..c57e02eebeb 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -47,6 +47,10 @@ let FSharpScriptFileSuffixes = [ ".fsscript"; ".fsx" ] let FSharpIndentationAwareSyntaxFileSuffixes = [ ".fs"; ".fsscript"; ".fsx"; ".fsi" ] +let FsharpExperimentalFeaturesEnabledAutomatically = + String.IsNullOrWhiteSpace(Environment.GetEnvironmentVariable("FSHARP_EXPERIMENTAL_FEATURES")) + |> not + //-------------------------------------------------------------------------- // General file name resolver //-------------------------------------------------------------------------- @@ -508,6 +512,7 @@ type TcConfigBuilder = mutable deterministic: bool mutable concurrentBuild: bool mutable parallelCheckingWithSignatureFiles: bool + mutable parallelIlxGen: bool mutable emitMetadataAssembly: MetadataAssemblyGeneration mutable preferredUiLang: string option mutable lcid: int option @@ -734,7 +739,8 @@ type TcConfigBuilder = emitTailcalls = true deterministic = false concurrentBuild = true - parallelCheckingWithSignatureFiles = false + parallelCheckingWithSignatureFiles = FsharpExperimentalFeaturesEnabledAutomatically + parallelIlxGen = FsharpExperimentalFeaturesEnabledAutomatically emitMetadataAssembly = MetadataAssemblyGeneration.None preferredUiLang = None lcid = None @@ -1289,6 +1295,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.deterministic = data.deterministic member _.concurrentBuild = data.concurrentBuild member _.parallelCheckingWithSignatureFiles = data.parallelCheckingWithSignatureFiles + member _.parallelIlxGen = data.parallelIlxGen member _.emitMetadataAssembly = data.emitMetadataAssembly member _.pathMap = data.pathMap member _.langVersion = data.langVersion diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi index 95e26b637ef..08637bc5d45 100644 --- a/src/Compiler/Driver/CompilerConfig.fsi +++ b/src/Compiler/Driver/CompilerConfig.fsi @@ -414,6 +414,8 @@ type TcConfigBuilder = mutable parallelCheckingWithSignatureFiles: bool + mutable parallelIlxGen: bool + mutable emitMetadataAssembly: MetadataAssemblyGeneration mutable preferredUiLang: string option @@ -736,6 +738,8 @@ type TcConfig = member parallelCheckingWithSignatureFiles: bool + member parallelIlxGen: bool + member emitMetadataAssembly: MetadataAssemblyGeneration member pathMap: PathMap diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 6d5da331a82..a221bb914d9 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -1394,6 +1394,7 @@ let testFlag tcConfigB = | "ContinueAfterParseFailure" -> tcConfigB.continueAfterParseFailure <- true | "ParallelOff" -> tcConfigB.concurrentBuild <- false | "ParallelCheckingWithSignatureFilesOn" -> tcConfigB.parallelCheckingWithSignatureFiles <- true + | "ParallelIlxGen" -> tcConfigB.parallelIlxGen <- true #if DEBUG | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true #endif diff --git a/src/Compiler/Driver/OptimizeInputs.fs b/src/Compiler/Driver/OptimizeInputs.fs index 0696758780b..4c4dac6ac36 100644 --- a/src/Compiler/Driver/OptimizeInputs.fs +++ b/src/Compiler/Driver/OptimizeInputs.fs @@ -255,6 +255,7 @@ let GenerateIlxCode isInteractive = tcConfig.isInteractive isInteractiveItExpr = isInteractiveItExpr alwaysCallVirt = tcConfig.alwaysCallVirt + parallelIlxGenEnabled = tcConfig.parallelIlxGen && not (tcConfig.deterministic) } ilxGenerator.GenerateCode(ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs, topAttrs.netModuleAttrs) diff --git a/src/Compiler/Driver/StaticLinking.fs b/src/Compiler/Driver/StaticLinking.fs index 17bc4882768..972f55fc70c 100644 --- a/src/Compiler/Driver/StaticLinking.fs +++ b/src/Compiler/Driver/StaticLinking.fs @@ -98,7 +98,7 @@ type TypeForwarding(tcImports: TcImports) = member _.TypeForwardILTypeRef tref = typeForwardILTypeRef tref -let debugStaticLinking = condition "FSHARP_DEBUG_STATIC_LINKING" +let debugStaticLinking = isEnvVarSet "FSHARP_DEBUG_STATIC_LINKING" let StaticLinkILModules ( diff --git a/src/Compiler/Interactive/fsi.fs b/src/Compiler/Interactive/fsi.fs index 69917433357..64d9c131287 100644 --- a/src/Compiler/Interactive/fsi.fs +++ b/src/Compiler/Interactive/fsi.fs @@ -3729,7 +3729,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i /// A background thread is started by this thread to read from the inReader and/or console reader. member x.Run() = - progress <- condition "FSHARP_INTERACTIVE_PROGRESS" + progress <- isEnvVarSet "FSHARP_INTERACTIVE_PROGRESS" // Explanation: When Run is called we do a bunch of processing. For fsi.exe // and fsiAnyCpu.exe there are no other active threads at this point, so we can assume this is the diff --git a/src/Compiler/TypedTree/CompilerGlobalState.fs b/src/Compiler/TypedTree/CompilerGlobalState.fs index b7eea4fb718..7047fc3cf35 100644 --- a/src/Compiler/TypedTree/CompilerGlobalState.fs +++ b/src/Compiler/TypedTree/CompilerGlobalState.fs @@ -4,7 +4,10 @@ module FSharp.Compiler.CompilerGlobalState +open System open System.Collections.Generic +open System.Collections.Concurrent +open System.Threading open FSharp.Compiler.Syntax.PrettyNaming open FSharp.Compiler.Text @@ -15,26 +18,15 @@ open FSharp.Compiler.Text /// 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 = Dictionary(100) - +type NiceNameGenerator() = + let basicNameCounts = ConcurrentDictionary>(max Environment.ProcessorCount 1, 127) + member _.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 _.Reset () = - lock lockObj (fun () -> - basicNameCounts.Clear() - ) + let countCell = basicNameCounts.GetOrAdd(basicName,fun k -> ref 0) + let count = Interlocked.Increment(countCell) + + CompilerGeneratedNameSuffix basicName (string m.StartLine + (match (count-1) with 0 -> "" | n -> "-" + string n)) /// 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 @@ -42,35 +34,15 @@ type NiceNameGenerator() = /// /// 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() = +type StableNiceNameGenerator() = - let lockObj = obj() - - let names = Dictionary(100) - let basicNameCounts = Dictionary(100) + let niceNames = ConcurrentDictionary(max Environment.ProcessorCount 1, 127) + let innerGenerator = new NiceNameGenerator() 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 basicName = GetBasicNameOfPossibleCompilerGeneratedName name + let key = basicName, uniq + niceNames.GetOrAdd(key, fun _ -> innerGenerator.FreshCompilerGeneratedName(name, m)) type internal CompilerGlobalState () = /// A global generator of compiler generated names @@ -92,12 +64,10 @@ type internal CompilerGlobalState () = type Unique = int64 //++GLOBAL MUTABLE STATE (concurrency-safe) -let newUnique = - let i = ref 0L - fun () -> System.Threading.Interlocked.Increment i +let mutable private uniqueCount = 0L +let newUnique() = System.Threading.Interlocked.Increment &uniqueCount /// Unique name generator for stamps attached to to val_specs, tycon_specs etc. //++GLOBAL MUTABLE STATE (concurrency-safe) -let newStamp = - let i = ref 0L - fun () -> System.Threading.Interlocked.Increment i +let mutable private stampCount = 0L +let newStamp() = System.Threading.Interlocked.Increment &stampCount diff --git a/src/Compiler/TypedTree/CompilerGlobalState.fsi b/src/Compiler/TypedTree/CompilerGlobalState.fsi index 105ab236f9e..6f0dba79ddf 100644 --- a/src/Compiler/TypedTree/CompilerGlobalState.fsi +++ b/src/Compiler/TypedTree/CompilerGlobalState.fsi @@ -17,7 +17,6 @@ type NiceNameGenerator = new: unit -> NiceNameGenerator member FreshCompilerGeneratedName: name: string * m: range -> string - member Reset: unit -> unit /// 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 @@ -29,7 +28,6 @@ type StableNiceNameGenerator = new: unit -> StableNiceNameGenerator member GetUniqueCompilerGeneratedName: name: string * m: range * uniq: int64 -> string - member Reset: unit -> unit type internal CompilerGlobalState = diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index 11ed90c37fa..8b066b3f489 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -1031,28 +1031,21 @@ module CancellableAutoOpens = /// Generates unique stamps type UniqueStampGenerator<'T when 'T: equality>() = - let gate = obj () - let encodeTab = ConcurrentDictionary<'T, int>(HashIdentity.Structural) - let mutable nItems = 0 + let encodeTable = ConcurrentDictionary<'T, Lazy>(HashIdentity.Structural) + let mutable nItems = -1 - let encode str = - match encodeTab.TryGetValue str with - | true, idx -> idx - | _ -> - lock gate (fun () -> - let idx = nItems - encodeTab[str] <- idx - nItems <- nItems + 1 - idx) + let computeFunc = Func<'T, _>(fun _ -> lazy (Interlocked.Increment(&nItems))) - member _.Encode str = encode str + member _.Encode str = + encodeTable.GetOrAdd(str, computeFunc).Value - member _.Table = encodeTab.Keys + member _.Table = encodeTable.Keys /// memoize tables (all entries cached, never collected) type MemoizationTable<'T, 'U>(compute: 'T -> 'U, keyComparer: IEqualityComparer<'T>, ?canMemoize) = - let table = new ConcurrentDictionary<'T, 'U>(keyComparer) + let table = new ConcurrentDictionary<'T, Lazy<'U>>(keyComparer) + let computeFunc = Func<_, _>(fun key -> lazy (compute key)) member t.Apply x = if @@ -1060,19 +1053,32 @@ type MemoizationTable<'T, 'U>(compute: 'T -> 'U, keyComparer: IEqualityComparer< | None -> true | Some f -> f x) then - match table.TryGetValue x with - | true, res -> res - | _ -> - lock table (fun () -> - match table.TryGetValue x with - | true, res -> res - | _ -> - let res = compute x - table[x] <- res - res) + table.GetOrAdd(x, computeFunc).Value else compute x +/// A thread-safe lookup table which is assigning an auto-increment stamp with each insert +type internal StampedDictionary<'T, 'U>(keyComparer: IEqualityComparer<'T>) = + let table = new ConcurrentDictionary<'T, Lazy>(keyComparer) + let mutable count = -1 + + member _.Add(key, value) = + let entry = table.GetOrAdd(key, lazy (Interlocked.Increment(&count), value)) + entry.Force() |> ignore + + member _.UpdateIfExists(key, valueReplaceFunc) = + match table.TryGetValue key with + | true, v -> + let (stamp, oldVal) = v.Value + + match valueReplaceFunc oldVal with + | None -> () + | Some newVal -> table.TryUpdate(key, lazy (stamp, newVal), v) |> ignore + | _ -> () + + member _.GetAll() = + table |> Seq.map (fun kvp -> kvp.Key, kvp.Value.Value) + exception UndefinedException type LazyWithContextFailure(exn: exn) = diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index 5696a14da98..26c8fb21db4 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -438,6 +438,17 @@ type internal MemoizationTable<'T, 'U> = member Apply: x: 'T -> 'U +/// A thread-safe lookup table which is assigning an auto-increment stamp with each insert +type internal StampedDictionary<'T, 'U> = + + new: keyComparer: IEqualityComparer<'T> -> StampedDictionary<'T, 'U> + + member Add: key: 'T * value: 'U -> unit + + member UpdateIfExists: key: 'T * valueReplaceFunc: ('U -> 'U option) -> unit + + member GetAll: unit -> seq<'T * (int * 'U)> + exception internal UndefinedException type internal LazyWithContextFailure = diff --git a/src/Compiler/Utilities/lib.fs b/src/Compiler/Utilities/lib.fs index 95a20226a2d..bc03a8de2ab 100755 --- a/src/Compiler/Utilities/lib.fs +++ b/src/Compiler/Utilities/lib.fs @@ -21,7 +21,7 @@ let mutable progress = false // Intended to be a general hook to control diagnostic output when tracking down bugs let mutable tracking = false -let condition s = +let isEnvVarSet s = try (Environment.GetEnvironmentVariable(s) <> null) with _ -> false let GetEnvInteger e dflt = match Environment.GetEnvironmentVariable(e) with null -> dflt | t -> try int t with _ -> dflt @@ -73,37 +73,6 @@ module NameMap = let domain m = Map.foldBack (fun x _ acc -> Zset.add x acc) m (Zset.empty String.order) let domainL m = Zset.elements (domain m) -// Library: Pre\Post checks -//------------------------------------------------------------------------- -module Check = - - /// Throw System.InvalidOperationException if argument is None. - /// If there is a value (e.g. Some(value)) then value is returned. - let NotNone argName (arg:'T option) : 'T = - match arg with - | None -> raise (InvalidOperationException(argName)) - | Some x -> x - - /// Throw System.ArgumentNullException if argument is null. - let ArgumentNotNull arg argName = - match box(arg) with - | null -> raise (ArgumentNullException(argName)) - | _ -> () - - /// Throw System.ArgumentNullException if array argument is null. - /// Throw System.ArgumentOutOfRangeException is array argument is empty. - let ArrayArgumentNotNullOrEmpty (arr:'T[]) argName = - ArgumentNotNull arr argName - if (0 = arr.Length) then - raise (ArgumentOutOfRangeException(argName)) - - /// Throw System.ArgumentNullException if string argument is null. - /// Throw System.ArgumentOutOfRangeException is string argument is empty. - let StringArgumentNotNullOrEmpty (s:string) argName = - ArgumentNotNull s argName - if s.Length = 0 then - raise (ArgumentNullException(argName)) - //------------------------------------------------------------------------- // Library //------------------------------------------------------------------------ @@ -285,8 +254,6 @@ let mapTriple (f1, f2, f3) (a1, a2, a3) = (f1 a1, f2 a2, f3 a3) let mapQuadruple (f1, f2, f3, f4) (a1, a2, a3, a4) = (f1 a1, f2 a2, f3 a3, f4 a4) -let fmap2Of2 f z (a1, a2) = let z, a2 = f z a2 in z, (a1, a2) - //--------------------------------------------------------------------------- // Zmap rebinds //------------------------------------------------------------------------- @@ -312,8 +279,6 @@ module Zset = if Zset.equal s s0 then s0 (* fixed *) else fixpoint f s (* iterate *) -let equalOn f x y = (f x) = (f y) - /// Buffer printing utility let buildString f = let buf = StringBuilder 100 @@ -420,92 +385,6 @@ type Dumper(x:obj) = [] member self.Dump = sprintf "%A" x #endif - -//--------------------------------------------------------------------------- -// AsyncUtil -//--------------------------------------------------------------------------- - -module internal AsyncUtil = - open Microsoft.FSharp.Control - - /// Represents the reified result of an asynchronous computation. - [] - type AsyncResult<'T> = - | AsyncOk of 'T - | AsyncException of exn - | AsyncCanceled of OperationCanceledException - - static member Commit(res:AsyncResult<'T>) = - Async.FromContinuations (fun (cont, eCont, cCont) -> - match res with - | AsyncOk v -> cont v - | AsyncException exn -> eCont exn - | AsyncCanceled exn -> cCont exn) - - /// When using .NET 4.0 you can replace this type by - [] - type AsyncResultCell<'T>() = - let mutable result = None - // The continuation for the result, if any - let mutable savedConts = [] - - let syncRoot = obj() - - - // Record the result in the AsyncResultCell. - // Ignore subsequent sets of the result. This can happen, e.g. for a race between - // a cancellation and a success. - member x.RegisterResult (res:AsyncResult<'T>) = - let grabbedConts = - lock syncRoot (fun () -> - if result.IsSome then - [] - else - result <- Some res - // Invoke continuations in FIFO order - // Continuations that Async.FromContinuations provide do QUWI/SyncContext.Post, - // so the order is not overly relevant but still. - List.rev savedConts) - let postOrQueue (sc:SynchronizationContext, cont) = - match sc with - | null -> ThreadPool.QueueUserWorkItem(fun _ -> cont res) |> ignore - | sc -> sc.Post((fun _ -> cont res), state=null) - - // Run continuations outside the lock - match grabbedConts with - | [] -> () - | [sc, cont as c] -> - if SynchronizationContext.Current = sc then - cont res - else - postOrQueue c - | _ -> - grabbedConts |> List.iter postOrQueue - - /// Get the reified result. - member private x.AsyncPrimitiveResult = - Async.FromContinuations(fun (cont, _, _) -> - let grabbedResult = - lock syncRoot (fun () -> - match result with - | Some _ -> - result - | None -> - // Otherwise save the continuation and call it in RegisterResult - let sc = SynchronizationContext.Current - savedConts <- (sc, cont) :: savedConts - None) - // Run the action outside the lock - match grabbedResult with - | None -> () - | Some res -> cont res) - - - /// Get the result and Commit(...). - member x.AsyncResult = - async { let! res = x.AsyncPrimitiveResult - return! AsyncResult.Commit(res) } - //--------------------------------------------------------------------------- // EnableHeapTerminationOnCorruption() //--------------------------------------------------------------------------- diff --git a/src/Compiler/Utilities/lib.fsi b/src/Compiler/Utilities/lib.fsi index bab85ccd414..2e6b0318f7a 100644 --- a/src/Compiler/Utilities/lib.fsi +++ b/src/Compiler/Utilities/lib.fsi @@ -15,7 +15,7 @@ val mutable progress: bool val mutable tracking: bool -val condition: s: string -> bool +val isEnvVarSet: s: string -> bool val GetEnvInteger: e: string -> dflt: int -> int @@ -64,22 +64,6 @@ module NameMap = val domainL: m: Map -> string list -module Check = - /// Throw System.InvalidOperationException if argument is None. - /// If there is a value (e.g. Some(value)) then value is returned. - val NotNone: argName: string -> arg: 'T option -> 'T - - /// Throw System.ArgumentNullException if argument is null. - val ArgumentNotNull: arg: 'a -> argName: string -> unit - - /// Throw System.ArgumentNullException if array argument is null. - /// Throw System.ArgumentOutOfRangeException is array argument is empty. - val ArrayArgumentNotNullOrEmpty: arr: 'T[] -> argName: string -> unit - - /// Throw System.ArgumentNullException if string argument is null. - /// Throw System.ArgumentOutOfRangeException is string argument is empty. - val StringArgumentNotNullOrEmpty: s: string -> argName: string -> unit - type IntMap<'T> = Zmap module IntMap = @@ -214,8 +198,6 @@ val mapQuadruple: a1: 'a * a2: 'c * a3: 'e * a4: 'g -> 'b * 'd * 'f * 'h -val fmap2Of2: f: ('a -> 'b -> 'c * 'd) -> z: 'a -> a1: 'e * a2: 'b -> 'c * ('e * 'd) - module Zmap = val force: k: 'a -> mp: Zmap<'a, 'b> -> 'b val mapKey: key: 'a -> f: ('b option -> 'b option) -> mp: Zmap<'a, 'b> -> Zmap<'a, 'b> @@ -224,8 +206,6 @@ module Zset = val ofList: order: IComparer<'a> -> xs: 'a list -> Zset<'a> val fixpoint: f: (Zset<'a> -> Zset<'a>) -> Zset<'a> -> Zset<'a> -val equalOn: f: ('a -> 'b) -> x: 'a -> y: 'a -> bool when 'b: equality - /// Buffer printing utility val buildString: f: (StringBuilder -> unit) -> string @@ -267,25 +247,6 @@ val inline cacheOptRef: cache: 'a option ref -> f: (unit -> 'a) -> 'a val inline tryGetCacheValue: cache: cache<'a> -> NonNullSlot<'a> voption -module AsyncUtil = - - /// Represents the reified result of an asynchronous computation. - [] - type AsyncResult<'T> = - | AsyncOk of 'T - | AsyncException of exn - | AsyncCanceled of System.OperationCanceledException - - static member Commit: res: AsyncResult<'T> -> Async<'T> - - /// When using .NET 4.0 you can replace this type by - [] - type AsyncResultCell<'T> = - - new: unit -> AsyncResultCell<'T> - member RegisterResult: res: AsyncResult<'T> -> unit - member AsyncResult: Async<'T> - module UnmanagedProcessExecutionOptions = val EnableHeapTerminationOnCorruption: unit -> unit