WIP Async2

src/Compiler/Checking/CheckDeclarations.fs

@@ -4870,9 +4870,9 @@ module TcDeclarations =
 //-------------------------------------------------------------------------
 // Bind module types
 //------------------------------------------------------------------------- 
-
-let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcEnv) synSigDecl: Cancellable<TcEnv> =
-  cancellable {
+#nowarn 3511
+let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcEnv) synSigDecl: Async2<TcEnv> =
+  async2 {
     let g = cenv.g
     try 
         match synSigDecl with 
@@ -5021,14 +5021,14 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE
 
             return env
 
-    with RecoverableException exn -> 
+    with exn -> 
         errorRecovery exn endm 
         return env
   }
 
 
 and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = 
-    cancellable {
+    async2 {
         // Ensure the .Deref call in UpdateAccModuleOrNamespaceType succeeds 
         if cenv.compilingCanonicalFslibModuleType then
             let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
@@ -5044,10 +5044,16 @@ and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs =
     }
 
 and TcSignatureElementsNonMutRec cenv parent typeNames endm env defs = 
-    Cancellable.fold (TcSignatureElementNonMutRec cenv parent typeNames endm) env defs
+    async2 {
+        match defs with
+        | [] -> return env
+        | def :: rest ->
+            let! env = TcSignatureElementNonMutRec cenv parent typeNames endm env def
+            return! TcSignatureElementsNonMutRec cenv parent typeNames endm env rest
+    }
 
 and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (defs: SynModuleSigDecl list) =
-    cancellable {
+    async2 {
         let m = match defs with [] -> m | _ -> defs |> List.map (fun d -> d.Range) |> List.reduce unionRanges
         let scopem = (defs, m) ||> List.foldBack (fun h m -> unionRanges h.Range m) 
 
@@ -5102,7 +5108,7 @@ and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (d
 
 and TcModuleOrNamespaceSignatureElementsNonMutRec cenv parent env (id, moduleKind, defs, m: range, xml) =
 
-  cancellable {
+  async2 {
     let endm = m.EndRange // use end of range for errors 
 
     // Create the module type that will hold the results of type checking.... 
@@ -5260,7 +5266,7 @@ let TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial
 
 /// The non-mutually recursive case for a declaration
 let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem env synDecl =   
-  cancellable {
+  async2 {
     let g = cenv.g
     cenv.synArgNameGenerator.Reset()
     let tpenv = emptyUnscopedTyparEnv
@@ -5371,7 +5377,6 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
               // Now typecheck. 
               let! moduleContents, topAttrsNew, envAtEnd = 
                 TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef moduleEntity)) endm envForModule xml None [] moduleDefs
-                |> cenv.stackGuard.GuardCancellable
 
               // Get the inferred type of the decls and record it in the modul. 
               moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value
@@ -5463,7 +5468,6 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
 
           let! moduleContents, topAttrs, envAtEnd = 
             TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs
-            |> cenv.stackGuard.GuardCancellable
 
           MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo 
           let env, openDecls = 
@@ -5493,20 +5497,17 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
           return 
               (defns, [], topAttrs), env, envAtEnd
 
-    with RecoverableException exn -> 
+    with exn -> 
         errorRecovery exn synDecl.Range 
         return ([], [], []), env, env
  }
 
 /// The non-mutually recursive case for a sequence of declarations
-and [<TailCall>] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) (ct: CancellationToken) =
-
-    if ct.IsCancellationRequested then
-        ValueOrCancelled.Cancelled(OperationCanceledException ct)
-    else
+and TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) =
+    async2 {
         match moreDefs with
         | [] ->
-            ValueOrCancelled.Value (List.rev defsSoFar, envAtEnd)
+            return List.rev defsSoFar, envAtEnd
         | firstDef :: otherDefs ->
             // Lookahead one to find out the scope of the next declaration.
             let scopem =
@@ -5515,17 +5516,12 @@ and [<TailCall>] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm
                 else
                     unionRanges (List.head otherDefs).Range endm
 
-            let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef |> cenv.stackGuard.GuardCancellable)
-
-            match result with
-            | ValueOrCancelled.Cancelled x ->
-                ValueOrCancelled.Cancelled x
-            | ValueOrCancelled.Value(firstDef, env, envAtEnd) ->
-                TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ((firstDef :: defsSoFar), env, envAtEnd) otherDefs ct
-
+            let! firstDef, env, envAtEnd = TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef
+            return! TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ((firstDef :: defsSoFar), env, envAtEnd) otherDefs
+    }
 
 and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 synModuleDecls =
-  cancellable {
+  async2 {
     // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds 
     if cenv.compilingCanonicalFslibModuleType then
         let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
@@ -5547,21 +5543,15 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0
         return (moduleContents, topAttrsNew, envAtEnd)
 
     | None ->
-        let! ct = Cancellable.token ()
-        let result = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls ct
-
-        match result with
-        | ValueOrCancelled.Value(compiledDefs, envAtEnd) ->
-            // Apply the functions for each declaration to build the overall expression-builder
-            let moduleDefs = List.collect p13 compiledDefs
-            let moduleDefs = match openDecls0 with [] -> moduleDefs | _ -> TMDefOpens openDecls0 :: moduleDefs
-            let moduleContents = TMDefs moduleDefs
-
-            // Collect up the attributes that are global to the file
-            let topAttrsNew = List.collect p33 compiledDefs
-            return (moduleContents, topAttrsNew, envAtEnd)
-        | ValueOrCancelled.Cancelled x -> 
-            return! Cancellable(fun _ -> ValueOrCancelled.Cancelled x)
+        let! compiledDefs, envAtEnd = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls
+        // Apply the functions for each declaration to build the overall expression-builder
+        let moduleDefs = List.collect p13 compiledDefs
+        let moduleDefs = match openDecls0 with [] -> moduleDefs | _ -> TMDefOpens openDecls0 :: moduleDefs
+        let moduleContents = TMDefs moduleDefs
+
+        // Collect up the attributes that are global to the file
+        let topAttrsNew = List.collect p33 compiledDefs
+        return (moduleContents, topAttrsNew, envAtEnd)
   }
 
 
@@ -5773,7 +5763,7 @@ let CheckOneImplFile
     let (ParsedImplFileInput (fileName, isScript, qualNameOfFile, _, implFileFrags, isLastCompiland, _, _)) = synImplFile
     let infoReader = InfoReader(g, amap)
 
-    cancellable {
+    async2 {
         use _ =
             Activity.start "CheckDeclarations.CheckOneImplFile"
                 [|
@@ -5798,7 +5788,6 @@ let CheckOneImplFile
         let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment x ]
         let! moduleContents, topAttrs, envAtEnd = 
             TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs
-            |> cenv.stackGuard.GuardCancellable
 
         let implFileTypePriorToSig = moduleTyAcc.Value
 
@@ -5918,7 +5907,7 @@ let CheckOneImplFile
 
 /// Check an entire signature file
 let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSink, isInternalTestSpanStackReferring, diagnosticOptions) tcEnv (sigFile: ParsedSigFileInput) =
- cancellable {     
+ async2 {     
     use _ =
         Activity.start "CheckDeclarations.CheckOneSigFile"
             [|
@@ -5949,7 +5938,7 @@ let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSin
         try
             sigFileType |> IterTyconsOfModuleOrNamespaceType (fun tycon ->
                 FinalTypeDefinitionChecksAtEndOfInferenceScope(cenv.infoReader, tcEnv.NameEnv, cenv.tcSink, false, tcEnv.DisplayEnv, tycon))
-        with RecoverableException exn -> errorRecovery exn sigFile.QualifiedName.Range
+        with exn -> errorRecovery exn sigFile.QualifiedName.Range
 
     UpdatePrettyTyparNames.updateModuleOrNamespaceType sigFileType
 

src/Compiler/Checking/CheckDeclarations.fsi

@@ -60,7 +60,7 @@ val CheckOneImplFile:
     ModuleOrNamespaceType option *
     ParsedImplFileInput *
     FSharpDiagnosticOptions ->
-        Cancellable<TopAttribs * CheckedImplFile * TcEnv * bool>
+        Async2<TopAttribs * CheckedImplFile * TcEnv * bool>
 
 val CheckOneSigFile:
     TcGlobals *
@@ -73,7 +73,7 @@ val CheckOneSigFile:
     FSharpDiagnosticOptions ->
         TcEnv ->
         ParsedSigFileInput ->
-            Cancellable<TcEnv * ModuleOrNamespaceType * bool>
+            Async2<TcEnv * ModuleOrNamespaceType * bool>
 
 exception NotUpperCaseConstructor of range: range
 

src/Compiler/Driver/ParseAndCheckInputs.fs

@@ -1225,8 +1225,8 @@ let CheckOneInput
         tcSink: TcResultsSink,
         tcState: TcState,
         input: ParsedInput
-    ) : Cancellable<PartialResult * TcState> =
-    cancellable {
+    ) : Async2<PartialResult * TcState> =
+    async2 {
         try
             use _ =
                 Activity.start "ParseAndCheckInputs.CheckOneInput" [| Activity.Tags.fileName, input.FileName |]
@@ -1344,7 +1344,7 @@ let DiagnosticsLoggerForInput (tcConfig: TcConfig, oldLogger) =
 
 /// Typecheck a single file (or interactive entry into F# Interactive)
 let CheckOneInputEntry (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt) tcState input =
-    cancellable {
+    async2 {
         // Equip loggers to locally filter w.r.t. scope pragmas in each input
         use _ =
             UseTransformedDiagnosticsLogger(fun oldLogger -> DiagnosticsLoggerForInput(tcConfig, oldLogger))
@@ -1355,7 +1355,7 @@ let CheckOneInputEntry (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcG
 
         return! CheckOneInput(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, input)
     }
-    |> Cancellable.runWithoutCancellation
+    |> Async2.runWithoutCancellation
 
 /// Finish checking multiple files (or one interactive entry into F# Interactive)
 let CheckMultipleInputsFinish (results, tcState: TcState) =
@@ -1371,7 +1371,7 @@ let CheckMultipleInputsFinish (results, tcState: TcState) =
     (tcEnvAtEndOfLastFile, topAttrs, implFiles, ccuSigsForFiles), tcState
 
 let CheckOneInputAndFinish (checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) =
-    cancellable {
+    async2 {
         let! result, tcState = CheckOneInput(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input)
         let finishedResult = CheckMultipleInputsFinish([ result ], tcState)
         return finishedResult
@@ -1445,8 +1445,8 @@ let CheckOneInputWithCallback
          _skipImplIfSigExists: bool):
             (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool
     )
-    : Cancellable<Finisher<NodeToTypeCheck, TcState, PartialResult>> =
-    cancellable {
+    : Async2<Finisher<NodeToTypeCheck, TcState, PartialResult>> =
+    async2 {
         try
             CheckSimulateException tcConfig
 
@@ -1820,7 +1820,7 @@ let CheckMultipleInputsUsingGraphMode
         : Finisher<NodeToTypeCheck, State, PartialResult> =
 
         let (Finisher(finisher = finisher)) =
-            cancellable {
+            async2 {
                 use _ = UseDiagnosticsLogger logger
 
                 let checkForErrors2 () =
@@ -1833,7 +1833,7 @@ let CheckMultipleInputsUsingGraphMode
                         node
                         (checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, false)
             }
-            |> Cancellable.runWithoutCancellation
+            |> Async2.runWithoutCancellation
 
         Finisher(
             node,

src/Compiler/Driver/ParseAndCheckInputs.fsi

@@ -180,7 +180,7 @@ val CheckOneInput:
     tcSink: NameResolution.TcResultsSink *
     tcState: TcState *
     input: ParsedInput ->
-        Cancellable<(TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType) * TcState>
+        Async2<(TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType) * TcState>
 
 val CheckOneInputWithCallback:
     node: NodeToTypeCheck ->
@@ -193,7 +193,7 @@ val CheckOneInputWithCallback:
     tcState: TcState *
     input: ParsedInput *
     _skipImplIfSigExists: bool ->
-        Cancellable<Finisher<NodeToTypeCheck, TcState, PartialResult>>
+        Async2<Finisher<NodeToTypeCheck, TcState, PartialResult>>
 
 val AddCheckResultsToTcState:
     tcGlobals: TcGlobals *
@@ -248,4 +248,4 @@ val CheckOneInputAndFinish:
     tcSink: NameResolution.TcResultsSink *
     tcState: TcState *
     input: ParsedInput ->
-        Cancellable<(TcEnv * TopAttribs * CheckedImplFile list * ModuleOrNamespaceType list) * TcState>
+        Async2<(TcEnv * TopAttribs * CheckedImplFile list * ModuleOrNamespaceType list) * TcState>

src/Compiler/FSharp.Compiler.Service.fsproj

@@ -128,6 +128,7 @@
     <Compile Include="Utilities\EditDistance.fs" />
     <Compile Include="Utilities\TaggedCollections.fsi" />
     <Compile Include="Utilities\TaggedCollections.fs" />
+    <Compile Include="Utilities\Async2.fs" />
     <Compile Include="Utilities\Cancellable.fsi" />
     <Compile Include="Utilities\Cancellable.fs" />
     <Compile Include="Utilities\FileSystem.fsi" />

src/Compiler/Facilities/DiagnosticsLogger.fs

@@ -909,10 +909,6 @@ type StackGuard(maxDepth: int, name: string) =
         finally
             depth <- depth - 1
 
-    [<DebuggerHidden; DebuggerStepThrough>]
-    member x.GuardCancellable(original: Cancellable<'T>) =
-        Cancellable(fun ct -> x.Guard(fun () -> Cancellable.run ct original))
-
     static member val DefaultDepth =
 #if DEBUG
         GetEnvInteger "FSHARP_DefaultStackGuardDepth" 50

src/Compiler/Facilities/DiagnosticsLogger.fsi

@@ -470,8 +470,6 @@ type StackGuard =
         [<CallerLineNumber; Optional; DefaultParameterValue(0)>] line: int ->
             'T
 
-    member GuardCancellable: Internal.Utilities.Library.Cancellable<'T> -> Internal.Utilities.Library.Cancellable<'T>
-
     static member GetDepthOption: string -> int
 
 /// This represents the global state established as each task function runs as part of the build.

src/Compiler/Interactive/fsi.fs

@@ -4797,7 +4797,7 @@ type FsiEvaluationSession
 
     member _.ParseAndCheckInteraction(code) =
         fsiInteractionProcessor.ParseAndCheckInteraction(legacyReferenceResolver, fsiInteractionProcessor.CurrentState, code)
-        |> Cancellable.runWithoutCancellation
+        |> Async2.runWithoutCancellation
 
     member _.InteractiveChecker = checker