Add Cancellable.CheckAndThrow

src/Compiler/Checking/CheckDeclarations.fs

@@ -1190,7 +1190,7 @@ module MutRecBindingChecking =
                             let inheritsExpr, tpenv =
                                 try 
                                    TcNewExpr cenv envInstance tpenv baseTy (Some synBaseTy.Range) true arg m
-                                with e ->
+                                with e when not e.IsOperationCancelled ->
                                     errorRecovery e m
                                     mkUnit g m, tpenv
                             let envInstance = match baseValOpt with Some baseVal -> AddLocalVal g cenv.tcSink scopem baseVal envInstance | None -> envInstance
@@ -1927,7 +1927,7 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env
 
       MutRecBindingChecking.TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv mBinds scopem mutRecNSInfo envMutRec binds
 
-    with exn -> errorRecovery exn scopem; [], envMutRec
+    with exn when not exn.IsOperationCancelled -> errorRecovery exn scopem; [], envMutRec
 
 //-------------------------------------------------------------------------
 // Build augmentation declarations
@@ -3050,7 +3050,7 @@ module EstablishTypeDefinitionCores =
                 if not inSig then 
                     cenv.amap.assemblyLoader.RecordGeneratedTypeRoot (ProviderGeneratedType(ilOrigRootTypeRef, ilTgtRootTyRef, nested))
 
-        with exn -> 
+        with exn when not exn.IsOperationCancelled -> 
             errorRecovery exn rhsType.Range 
 #endif
 
@@ -3145,7 +3145,7 @@ module EstablishTypeDefinitionCores =
 
             | _ -> ()
 
-        with exn -> 
+        with exn when not exn.IsOperationCancelled -> 
             errorRecovery exn m
 
     // Third phase: check and publish the super types. Run twice, once before constraints are established
@@ -3257,7 +3257,7 @@ module EstablishTypeDefinitionCores =
               // Publish the super type
               tycon.TypeContents.tcaug_super <- super
 
-           with exn -> errorRecovery exn m))
+           with exn when not exn.IsOperationCancelled -> errorRecovery exn m))
 
     /// Establish the fields, dispatch slots and union cases of a type
     let private TcTyconDefnCore_Phase1G_EstablishRepresentation (cenv: cenv) envinner tpenv inSig (MutRecDefnsPhase1DataForTycon(_, synTyconRepr, _, _, _, _)) (tycon: Tycon) (attrs: Attribs) =
@@ -3643,7 +3643,7 @@ module EstablishTypeDefinitionCores =
             | _ -> ()         
 
             (baseValOpt, safeInitInfo)
-        with exn -> 
+        with exn when not exn.IsOperationCancelled -> 
             errorRecovery exn m 
             None, NoSafeInitInfo
 
@@ -3864,7 +3864,7 @@ module EstablishTypeDefinitionCores =
                 let envForTycon = MakeInnerEnvForTyconRef envForTycon thisTyconRef false 
                 try
                     TcTyparConstraints cenv NoNewTypars checkConstraints ItemOccurence.UseInType envForTycon tpenv synTyconConstraints |> ignore
-                with exn ->
+                with exn when not exn.IsOperationCancelled ->
                     errorRecovery exn m
             | _ -> ())
 
@@ -4814,7 +4814,7 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE
 
             return env
 
-    with exn -> 
+    with exn when not exn.IsOperationCancelled -> 
         errorRecovery exn endm 
         return env
   }
@@ -5182,7 +5182,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
           return 
               (defns, [], topAttrs), env, envAtEnd
 
-    with exn -> 
+    with exn when not exn.IsOperationCancelled -> 
         errorRecovery exn synDecl.Range 
         return ([], [], []), env, env
  }
@@ -5404,7 +5404,7 @@ let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) =
     (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> 
         try 
             AddCcuToTcEnv(g, amap, scopem, env, assemblyName, ccu, autoOpens, internalsVisible)
-        with exn -> 
+        with exn when not exn.IsOperationCancelled -> 
             errorRecovery exn scopem 
             [], env) 
 
@@ -5455,7 +5455,7 @@ let ApplyDefaults (cenv: cenv) g denvAtEnd m moduleContents extraAttribs =
             if not tp.IsSolved then 
                 if (tp.StaticReq <> TyparStaticReq.None) then
                     ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp)
-    with exn ->
+    with exn when not exn.IsOperationCancelled ->
         errorRecovery exn m
 
 let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig m = 
@@ -5475,7 +5475,7 @@ let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig
                 | tp :: _ -> errorR (ValueRestriction(denvAtEnd, infoReader, false, v, tp, v.Range))
                 | _ -> ()
           mty.ModuleAndNamespaceDefinitions |> List.iter (fun v -> check v.ModuleOrNamespaceType) 
-      try check implFileTypePriorToSig with e -> errorRecovery e m
+      try check implFileTypePriorToSig with e when not e.IsOperationCancelled -> errorRecovery e m
 
 
 let SolveInternalUnknowns g (cenv: cenv) denvAtEnd moduleContents extraAttribs =
@@ -5513,7 +5513,7 @@ let CheckModuleSignature g (cenv: cenv) m denvAtEnd rootSigOpt implFileTypePrior
             if not (SignatureConformance.Checker(g, cenv.amap, denv, remapInfo, true).CheckSignature aenv cenv.infoReader (mkLocalModuleRef implFileSpecPriorToSig) sigFileType) then
                 // We can just raise 'ReportedError' since CheckModuleOrNamespace raises its own error 
                 raise (ReportedError None)
-        with exn ->
+        with exn when not exn.IsOperationCancelled ->
             errorRecovery exn m
 
         (sigFileType, moduleContents)
@@ -5591,7 +5591,7 @@ let CheckOneImplFile
           for check in cenv.css.GetPostInferenceChecksPreDefaults() do
             try  
                 check()
-            with exn -> 
+            with exn when not exn.IsOperationCancelled -> 
                 errorRecovery exn m
 
         conditionallySuppressErrorReporting (checkForErrors()) (fun () ->
@@ -5605,7 +5605,7 @@ let CheckOneImplFile
                 implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (fun tycon ->
                     FinalTypeDefinitionChecksAtEndOfInferenceScope (cenv.infoReader, envAtEnd.NameEnv, cenv.tcSink, true, denvAtEnd, tycon))
 
-            with exn ->
+            with exn when not exn.IsOperationCancelled ->
                 errorRecovery exn m)
 
         // Check the value restriction. Only checked if there is no signature.
@@ -5626,7 +5626,7 @@ let CheckOneImplFile
              for check in cenv.css.GetPostInferenceChecksFinal() do
                 try  
                     check()
-                with exn -> 
+                with exn when not exn.IsOperationCancelled -> 
                     errorRecovery exn m)
 
         // We ALWAYS run the PostTypeCheckSemanticChecks phase, though we if we have already encountered some
@@ -5645,7 +5645,7 @@ let CheckOneImplFile
                         implFileTy, implFileContents, extraAttribs, isLastCompiland, 
                         isInternalTestSpanStackReferring)
 
-                with exn -> 
+                with exn when not exn.IsOperationCancelled -> 
                     errorRecovery exn m
                     false, StampMap.Empty)
 
@@ -5707,7 +5707,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 exn -> errorRecovery exn sigFile.QualifiedName.Range
+        with exn when not exn.IsOperationCancelled -> errorRecovery exn sigFile.QualifiedName.Range
 
     UpdatePrettyTyparNames.updateModuleOrNamespaceType sigFileType
 

src/Compiler/Checking/CheckExpressions.fs

@@ -474,7 +474,7 @@ let UnifyOverallType (cenv: cenv) (env: TcEnv) m overallTy actualTy =
 let UnifyOverallTypeAndRecover (cenv: cenv) env m overallTy actualTy =
     try
         UnifyOverallType cenv env m overallTy actualTy
-    with exn ->
+    with exn when not exn.IsOperationCancelled ->
         errorRecovery exn m
 
 /// Make an environment suitable for a module or namespace. Does not create a new accumulator but uses one we already have/
@@ -4963,7 +4963,7 @@ and TcTypeOrMeasureAndRecover kindOpt (cenv: cenv) newOk checkConstraints occ iw
     let g = cenv.g
     try
         TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ iwsam env tpenv ty
-    with e ->
+    with e when not e.IsOperationCancelled ->
         errorRecovery e ty.Range
 
         let recoveryTy =
@@ -5156,7 +5156,7 @@ and TcExpr (cenv: cenv) ty (env: TcEnv) tpenv (synExpr: SynExpr) =
     // So be careful!
     try
         TcExprNoRecover cenv ty env tpenv synExpr
-    with exn ->
+    with exn when not exn.IsOperationCancelled ->
         let m = synExpr.Range
         // Error recovery - return some rubbish expression, but replace/annotate
         // the type of the current expression with a type variable that indicates an error
@@ -5185,7 +5185,7 @@ and TcExprOfUnknownTypeThen (cenv: cenv) env tpenv synExpr delayed =
     let expr, tpenv =
       try
           TcExprThen cenv (MustEqual exprTy) env tpenv false synExpr delayed
-      with exn ->
+      with exn when not exn.IsOperationCancelled ->
           let m = synExpr.Range
           errorRecovery exn m
           SolveTypeAsError env.DisplayEnv cenv.css m exprTy
@@ -10962,7 +10962,7 @@ and TcAttributesWithPossibleTargetsEx canFail (cenv: cenv) env attrTgt attrEx sy
 
             attribsAndTargets, didFail || didFail2
 
-        with e ->
+        with e when not e.IsOperationCancelled ->
             errorRecovery e synAttrib.Range
             [], false)
 

src/Compiler/Checking/CheckPatterns.fs

@@ -216,7 +216,7 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 valReprInfo (vFlags: TcPat
 and TcPatAndRecover warnOnUpper cenv (env: TcEnv) valReprInfo (vFlags: TcPatValFlags) patEnv ty (synPat: SynPat) =
     try
        TcPat warnOnUpper cenv env valReprInfo vFlags patEnv ty synPat
-    with e ->
+    with e when not e.IsOperationCancelled ->
         // Error recovery - return some rubbish expression, but replace/annotate
         // the type of the current expression with a type variable that indicates an error
         let m = synPat.Range
@@ -335,7 +335,7 @@ and TcConstPat warnOnUpper cenv env vFlags patEnv ty synConst m =
         try
             let c = TcConst cenv ty m env synConst
             (fun _ -> TPat_const (c, m)), patEnv
-        with e ->
+        with e when not e.IsOperationCancelled ->
             errorRecovery e m
             (fun _ -> TPat_error m), patEnv
 
@@ -394,7 +394,7 @@ and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m =
         match names2.TryGetValue id1.idText with
         | true, PrelimVal1 (id=id2; prelimType=ty2) ->
             try UnifyTypes cenv env id2.idRange ty1 ty2
-            with exn -> errorRecovery exn m
+            with exn when not exn.IsOperationCancelled -> errorRecovery exn m
         | _ -> ())
 
     let namesR = NameMap.layer names1 names2
@@ -417,7 +417,7 @@ and TcPatTuple warnOnUpper cenv env vFlags patEnv ty isExplicitStruct args m =
         let argsR, acc = TcPatterns warnOnUpper cenv env vFlags patEnv argTys args
         let phase2 values = TPat_tuple(tupInfo, List.map (fun f -> f values) argsR, argTys, m)
         phase2, acc
-    with e ->
+    with e when not e.IsOperationCancelled ->
         errorRecovery e m
         let _, acc = TcPatterns warnOnUpper cenv env vFlags patEnv (NewInferenceTypes g args) args
         let phase2 _ = TPat_error m
@@ -462,7 +462,7 @@ and TcRecordPat warnOnUpper cenv env vFlags patEnv ty fieldPats m =
 and TcNullPat cenv env patEnv ty m =
     try
         AddCxTypeUseSupportsNull env.DisplayEnv cenv.css m NoTrace ty
-    with exn ->
+    with exn when not exn.IsOperationCancelled ->
         errorRecovery exn m
     (fun _ -> TPat_null m), patEnv
 

src/Compiler/Checking/MethodOverrides.fs

@@ -826,7 +826,7 @@ module DispatchSlotChecking =
 
                     CheckOverridesAreAllUsedOnce (denv, g, infoReader, false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck)
 
-            with e -> errorRecovery e m
+            with e when not e.IsOperationCancelled -> errorRecovery e m
 
         // Now record the full slotsigs of the abstract members implemented by each override.
         // This is used to generate IL MethodImpls in the code generator.

src/Compiler/Checking/NameResolution.fs

@@ -568,7 +568,7 @@ let GetTyconRefForExtensionMembers minfo (deref: Entity) amap m g =
                 | AppTy g (tcrefOfTypeExtended, _) when not (isByrefTy g thisTy) -> Some tcrefOfTypeExtended
                 | _ -> None
         Some rs
-    with e -> // Import of the ILType may fail, if so report the error and skip on
+    with e when not e.IsOperationCancelled -> // Import of the ILType may fail, if so report the error and skip on
         errorRecovery e m
         None
 

src/Compiler/Checking/PatternMatchCompilation.fs

@@ -1146,6 +1146,8 @@ let CompilePatternBasic
 
     // The main recursive loop of the pattern match compiler.
     let rec InvestigateFrontiers refuted frontiers =
+        Cancellable.CheckAndThrow()
+
         match frontiers with
         | [] -> failwith "CompilePattern: compile - empty clauses: at least the final clause should always succeed"
         | Frontier (i, active, valMap) :: rest ->

src/Compiler/Checking/PostInferenceChecks.fs

@@ -2212,7 +2212,7 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) =
             match TryChopPropertyName v.DisplayName with
             | Some res -> check true res
             | None -> ()
-        with e -> errorRecovery e v.Range
+        with e when not e.IsOperationCancelled -> errorRecovery e v.Range
     end
 
     CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore

src/Compiler/Driver/CompilerConfig.fs

@@ -1211,7 +1211,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) =
                         | Some path when FileSystem.DirectoryExistsShim(path) -> yield path
                         | _ -> ()
             ]
-        with e ->
+        with e when not e.IsOperationCancelled ->
             errorRecovery e range0
             []
 
@@ -1408,7 +1408,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) =
                         None
                 else
                     Some(m, path)
-            with e ->
+            with e when not e.IsOperationCancelled ->
                 errorRecovery e m
                 None
 

src/Compiler/Driver/CompilerImports.fs

@@ -680,7 +680,7 @@ type TcAssemblyResolutions(tcConfig: TcConfig, results: AssemblyResolution list,
                                 tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.RaiseError, assemblyReference)
 
                             Choice1Of2 resolutionOpt.Value
-                        with e ->
+                        with e when not e.IsOperationCancelled ->
                             errorRecovery e assemblyReference.Range
                             Choice2Of2 assemblyReference)
 
@@ -1913,7 +1913,7 @@ and [<Sealed>] TcImports
 
                         for providedNamespace in providedNamespaces do
                             loop providedNamespace
-                    with e ->
+                    with e when not e.IsOperationCancelled ->
                         errorRecovery e m
 
                 if startingErrorCount < DiagnosticsThreadStatics.DiagnosticsLogger.ErrorCount then

src/Compiler/Driver/CompilerOptions.fs

@@ -2334,7 +2334,7 @@ let ApplyCommandLineArgs (tcConfigB: TcConfigBuilder, sourceFiles: string list,
 
         ParseCompilerOptions(collect, GetCoreServiceCompilerOptions tcConfigB, argv)
         sourceFilesAcc |> CheckAndReportSourceFileDuplicates
-    with e ->
+    with e when not e.IsOperationCancelled ->
         errorRecovery e range0
         sourceFiles