diff --git a/docs/release-notes/.FSharp.Compiler.Service/9.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/9.0.100.md index 27e8ed7350a..8c6b8f184c6 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/9.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/9.0.100.md @@ -16,6 +16,7 @@ * Parentheses analysis: keep extra parentheses around unit & tuples in method definitions. ([PR #17618](https://github.com/dotnet/fsharp/pull/17618)) * Fix IsUnionCaseTester throwing for non-methods/properties [#17301](https://github.com/dotnet/fsharp/pull/17634) * Consider `open type` used when the type is an enum and any of the enum cases is used unqualified. ([PR #17628](https://github.com/dotnet/fsharp/pull/17628)) +* Guard for possible StackOverflowException when typechecking non recursive modules and namespaces ([PR #17654](https://github.com/dotnet/fsharp/pull/17654)) ### Added diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 8a997f75ebb..96d3bb2b28d 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5113,8 +5113,106 @@ let CheckLetOrDoInNamespace binds m = | _ -> error(Error(FSComp.SR.tcNamespaceCannotContainValues(), binds.Head.RangeOfHeadPattern)) +let rec TcMutRecDefsFinish cenv defs m = + let opens = + [ for def in defs do + match def with + | MutRecShape.Open (MutRecDataForOpen (_target, _m, _moduleRange, openDeclsRef)) -> + yield! openDeclsRef.Value + | _ -> () ] + + let tycons = defs |> List.choose (function MutRecShape.Tycon (Some tycon, _) -> Some tycon | _ -> None) + + let binds = + defs |> List.collect (function + | MutRecShape.Open _ -> [] + | MutRecShape.ModuleAbbrev _ -> [] + | MutRecShape.Tycon (_, binds) + | MutRecShape.Lets binds -> + binds |> List.map ModuleOrNamespaceBinding.Binding + | MutRecShape.Module ((MutRecDefnsPhase2DataForModule(moduleTyAcc, moduleEntity), _), moduleDefs) -> + let moduleContents = TcMutRecDefsFinish cenv moduleDefs m + moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value + [ ModuleOrNamespaceBinding.Module(moduleEntity, moduleContents) ]) + + TMDefRec(true, opens, tycons, binds, m) + +/// The mutually recursive case for a sequence of declarations (and nested modules) +let TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial mutRecNSInfo (defs: SynModuleDecl list) = + 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) + + let mutRecDefns, (_, _, Attributes synAttrs) = + let rec loop isNamespace moduleRange attrs defs: MutRecDefnsInitialData * _ = + ((true, true, attrs), defs) ||> List.collectFold (fun (openOk, moduleAbbrevOk, attrs) def -> + match ElimSynModuleDeclExpr def with + + | SynModuleDecl.Types (typeDefs, _) -> + let decls = typeDefs |> List.map MutRecShape.Tycon + decls, (false, false, attrs) + + | SynModuleDecl.Let (letrec, binds, m) -> + let binds = + if isNamespace then + CheckLetOrDoInNamespace binds m; [] + else + if letrec then [MutRecShape.Lets binds] + else List.map (List.singleton >> MutRecShape.Lets) binds + binds, (false, false, attrs) + + | SynModuleDecl.NestedModule(moduleInfo = (SynComponentInfo(longId = []))) -> + [], (openOk, moduleAbbrevOk, attrs) + + | SynModuleDecl.NestedModule(moduleInfo=compInfo; isRecursive=isRec; decls=synDefs; range=moduleRange) -> + if isRec then warning(Error(FSComp.SR.tcRecImplied(), compInfo.Range)) + let mutRecDefs, (_, _, attrs) = loop false moduleRange attrs synDefs + let decls = [MutRecShape.Module (compInfo, mutRecDefs)] + decls, (false, false, attrs) + + | SynModuleDecl.Open (target, m) -> + if not openOk then errorR(Error(FSComp.SR.tcOpenFirstInMutRec(), m)) + let decls = [ MutRecShape.Open (MutRecDataForOpen(target, m, moduleRange, ref [])) ] + decls, (openOk, moduleAbbrevOk, attrs) + + | SynModuleDecl.Exception (SynExceptionDefn(repr, _, members, _), _m) -> + let members = desugarGetSetMembers members + let (SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _repr, xmlDoc, vis, m)) = repr + let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange) + let decls = [ MutRecShape.Tycon(SynTypeDefn(compInfo, SynTypeDefnRepr.Exception repr, members, None, m, SynTypeDefnTrivia.Zero)) ] + decls, (false, false, attrs) + + | SynModuleDecl.HashDirective _ -> + [ ], (openOk, moduleAbbrevOk, attrs) + + | SynModuleDecl.Attributes (synAttrs, _) -> + [ ], (false, false, synAttrs) + + | SynModuleDecl.ModuleAbbrev (id, p, m) -> + if not moduleAbbrevOk then errorR(Error(FSComp.SR.tcModuleAbbrevFirstInMutRec(), m)) + let decls = [ MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev(id, p, m)) ] + decls, (false, moduleAbbrevOk, attrs) + + | SynModuleDecl.Expr _ -> failwith "unreachable: SynModuleDecl.Expr - ElimSynModuleDeclExpr" + + | SynModuleDecl.NamespaceFragment _ as d -> error(Error(FSComp.SR.tcUnsupportedMutRecDecl(), d.Range))) + + loop (match parent with ParentNone -> true | Parent _ -> false) m [] defs + + let tpenv = emptyUnscopedTyparEnv + let mutRecDefnsChecked, envAfter = TcDeclarations.TcMutRecDefinitions cenv envInitial parent typeNames tpenv m scopem mutRecNSInfo mutRecDefns true + + // Check the assembly attributes + let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs + + // Check the non-escaping condition as we build the list of module expressions on the way back up + let moduleContents = TcMutRecDefsFinish cenv mutRecDefnsChecked m + let escapeCheck () = + TcMutRecDefnsEscapeCheck mutRecDefnsChecked envInitial + + ([ moduleContents ], [ escapeCheck ], attrs), envAfter, envAfter + /// The non-mutually recursive case for a declaration -let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem env synDecl = +let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem env synDecl = cancellable { let g = cenv.g cenv.synArgNameGenerator.Reset() @@ -5196,7 +5294,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem if isRec then assert (not isContinuingModule) let modDecl = SynModuleDecl.NestedModule(compInfo, false, moduleDefs, isContinuingModule, m, trivia) - return! TcModuleOrNamespaceElementsMutRec cenv parent typeNames m env None [modDecl] + return TcModuleOrNamespaceElementsMutRec cenv parent typeNames m env None [modDecl] else let (SynComponentInfo(Attributes attribs, _, _, longPath, xml, _, vis, im)) = compInfo let id = ComputeModuleName longPath @@ -5224,7 +5322,9 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem let moduleEntity = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id xmlDoc modAttrs (MaybeLazy.Strict moduleTy) // Now typecheck. - let! moduleContents, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef moduleEntity)) endm envForModule xml None [] moduleDefs + 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 @@ -5313,7 +5413,9 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem let nsInfo = Some (modulNSOpt, envNS.eModuleOrNamespaceTypeAccumulator) let mutRecNSInfo = if isRec then nsInfo else None - let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs + let! moduleContents, topAttrs, envAtEnd = + TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs + |> cenv.stackGuard.GuardCancellable MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo let env, openDecls = @@ -5365,7 +5467,7 @@ and [] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm else unionRanges (List.head otherDefs).Range endm - let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef) + let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef |> cenv.stackGuard.GuardCancellable) match result with | ValueOrCancelled.Cancelled x -> @@ -5373,107 +5475,6 @@ and [] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm | ValueOrCancelled.Value(firstDef, env, envAtEnd) -> TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ((firstDef :: defsSoFar), env, envAtEnd) otherDefs ct -/// The mutually recursive case for a sequence of declarations (and nested modules) -and TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial mutRecNSInfo (defs: SynModuleDecl list) = - cancellable { - - 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) - - let mutRecDefns, (_, _, Attributes synAttrs) = - let rec loop isNamespace moduleRange attrs defs: MutRecDefnsInitialData * _ = - ((true, true, attrs), defs) ||> List.collectFold (fun (openOk, moduleAbbrevOk, attrs) def -> - match ElimSynModuleDeclExpr def with - - | SynModuleDecl.Types (typeDefs, _) -> - let decls = typeDefs |> List.map MutRecShape.Tycon - decls, (false, false, attrs) - - | SynModuleDecl.Let (letrec, binds, m) -> - let binds = - if isNamespace then - CheckLetOrDoInNamespace binds m; [] - else - if letrec then [MutRecShape.Lets binds] - else List.map (List.singleton >> MutRecShape.Lets) binds - binds, (false, false, attrs) - - | SynModuleDecl.NestedModule(moduleInfo = (SynComponentInfo(longId = []))) -> - [], (openOk, moduleAbbrevOk, attrs) - - | SynModuleDecl.NestedModule(moduleInfo=compInfo; isRecursive=isRec; decls=synDefs; range=moduleRange) -> - if isRec then warning(Error(FSComp.SR.tcRecImplied(), compInfo.Range)) - let mutRecDefs, (_, _, attrs) = loop false moduleRange attrs synDefs - let decls = [MutRecShape.Module (compInfo, mutRecDefs)] - decls, (false, false, attrs) - - | SynModuleDecl.Open (target, m) -> - if not openOk then errorR(Error(FSComp.SR.tcOpenFirstInMutRec(), m)) - let decls = [ MutRecShape.Open (MutRecDataForOpen(target, m, moduleRange, ref [])) ] - decls, (openOk, moduleAbbrevOk, attrs) - - | SynModuleDecl.Exception (SynExceptionDefn(repr, _, members, _), _m) -> - let members = desugarGetSetMembers members - let (SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _repr, xmlDoc, vis, m)) = repr - let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange) - let decls = [ MutRecShape.Tycon(SynTypeDefn(compInfo, SynTypeDefnRepr.Exception repr, members, None, m, SynTypeDefnTrivia.Zero)) ] - decls, (false, false, attrs) - - | SynModuleDecl.HashDirective _ -> - [ ], (openOk, moduleAbbrevOk, attrs) - - | SynModuleDecl.Attributes (synAttrs, _) -> - [ ], (false, false, synAttrs) - - | SynModuleDecl.ModuleAbbrev (id, p, m) -> - if not moduleAbbrevOk then errorR(Error(FSComp.SR.tcModuleAbbrevFirstInMutRec(), m)) - let decls = [ MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev(id, p, m)) ] - decls, (false, moduleAbbrevOk, attrs) - - | SynModuleDecl.Expr _ -> failwith "unreachable: SynModuleDecl.Expr - ElimSynModuleDeclExpr" - - | SynModuleDecl.NamespaceFragment _ as d -> error(Error(FSComp.SR.tcUnsupportedMutRecDecl(), d.Range))) - - loop (match parent with ParentNone -> true | Parent _ -> false) m [] defs - - let tpenv = emptyUnscopedTyparEnv - let mutRecDefnsChecked, envAfter = TcDeclarations.TcMutRecDefinitions cenv envInitial parent typeNames tpenv m scopem mutRecNSInfo mutRecDefns true - - // Check the assembly attributes - let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs - - // Check the non-escaping condition as we build the list of module expressions on the way back up - let moduleContents = TcMutRecDefsFinish cenv mutRecDefnsChecked m - let escapeCheck () = - TcMutRecDefnsEscapeCheck mutRecDefnsChecked envInitial - - return ([ moduleContents ], [ escapeCheck ], attrs), envAfter, envAfter - - } - -and TcMutRecDefsFinish cenv defs m = - let opens = - [ for def in defs do - match def with - | MutRecShape.Open (MutRecDataForOpen (_target, _m, _moduleRange, openDeclsRef)) -> - yield! openDeclsRef.Value - | _ -> () ] - - let tycons = defs |> List.choose (function MutRecShape.Tycon (Some tycon, _) -> Some tycon | _ -> None) - - let binds = - defs |> List.collect (function - | MutRecShape.Open _ -> [] - | MutRecShape.ModuleAbbrev _ -> [] - | MutRecShape.Tycon (_, binds) - | MutRecShape.Lets binds -> - binds |> List.map ModuleOrNamespaceBinding.Binding - | MutRecShape.Module ((MutRecDefnsPhase2DataForModule(moduleTyAcc, moduleEntity), _), moduleDefs) -> - let moduleContents = TcMutRecDefsFinish cenv moduleDefs m - moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value - [ ModuleOrNamespaceBinding.Module(moduleEntity, moduleContents) ]) - - TMDefRec(true, opens, tycons, binds, m) and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 synModuleDecls = cancellable { @@ -5488,7 +5489,8 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 match mutRecNSInfo with | Some _ -> - let! (moduleDefs, escapeChecks, topAttrsNew), _, envAtEnd = TcModuleOrNamespaceElementsMutRec cenv parent typeNames endm env mutRecNSInfo synModuleDecls + let (moduleDefs, escapeChecks, topAttrsNew), _, envAtEnd = + TcModuleOrNamespaceElementsMutRec cenv parent typeNames endm env mutRecNSInfo synModuleDecls let moduleContents = TMDefs(moduleDefs) // Run the escape checks (for compat run in reverse order) do @@ -5746,7 +5748,9 @@ let CheckOneImplFile let envinner, moduleTyAcc = MakeInitialEnv env let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment x ] - let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs + let! moduleContents, topAttrs, envAtEnd = + TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs + |> cenv.stackGuard.GuardCancellable let implFileTypePriorToSig = moduleTyAcc.Value diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 345b7426c2a..cd883c6f7c7 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -473,7 +473,8 @@ type TcConfigBuilder = mutable printAllSignatureFiles: bool mutable xmlDocOutputFile: string option mutable stats: bool - mutable generateFilterBlocks: bool (* don't generate filter blocks due to bugs on Mono *) + mutable generateFilterBlocks: + bool (* Previously marked with: `don't generate filter blocks due to bugs on Mono`. However, the related bug has been fixed: https://github.com/dotnet/linker/issues/2181 *) mutable signer: string option mutable container: string option @@ -717,7 +718,7 @@ type TcConfigBuilder = printAllSignatureFiles = false xmlDocOutputFile = None stats = false - generateFilterBlocks = false (* don't generate filter blocks *) + generateFilterBlocks = false (* This was set as false due to an older bug in Mono https://github.com/dotnet/linker/issues/2181. This has been fixed in the meantime. *) signer = None container = None diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index e70856021f1..18d095c90f0 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -30,7 +30,9 @@ $(OtherFlags) --warnon:3218 $(OtherFlags) --warnon:3390 - true + + $(OtherFlags) --generate-filter-blocks + true $(IntermediateOutputPath)$(TargetFramework)\ $(IntermediateOutputPath)$(TargetFramework)\ false diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index 84e1cb55360..69d1f4fc306 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -903,6 +903,10 @@ type StackGuard(maxDepth: int, name: string) = finally depth <- depth - 1 + [] + 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 diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index 6cf3a5f2184..e5a4c8e7f8a 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -462,6 +462,8 @@ type StackGuard = [] 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. diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs new file mode 100644 index 00000000000..5d0c9febad7 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs @@ -0,0 +1,16 @@ +module ActivePatternTestCase + +open System + +[] +let (|RecoverableException|_|) (exn: Exception) = + match exn with + | :? OperationCanceledException -> ValueNone + | _ -> + ValueSome exn + +let addWithActivePattern (a:int) (b:int) = + try + a / b + with + | RecoverableException e -> a + b \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs.generateFilterBlocks.il.bsl b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs.generateFilterBlocks.il.bsl new file mode 100644 index 00000000000..170695eb40f --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs.generateFilterBlocks.il.bsl @@ -0,0 +1,146 @@ + + + + + +.assembly extern runtime { } +.assembly extern FSharp.Core { } +.assembly assembly +{ + .hash algorithm 0x00008004 + .ver 0:0:0:0 +} +.module assembly.exe + +.imagebase {value} +.file alignment 0x00000200 +.stackreserve 0x00100000 +.subsystem 0x0003 +.corflags 0x00000001 + + + + + +.class public abstract auto ansi sealed ActivePatternTestCase + extends [runtime]System.Object +{ + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) + .method public specialname static valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 '|RecoverableException|_|'(class [runtime]System.Exception exn) cil managed + { + .param [0] + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.StructAttribute::.ctor() = ( 01 00 00 00 ) + + .maxstack 3 + .locals init (class [runtime]System.Exception V_0, + class [runtime]System.OperationCanceledException V_1) + IL_0000: ldarg.0 + IL_0001: stloc.0 + IL_0002: ldloc.0 + IL_0003: isinst [runtime]System.OperationCanceledException + IL_0008: stloc.1 + IL_0009: ldloc.1 + IL_000a: brfalse.s IL_0012 + + IL_000c: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_ValueNone() + IL_0011: ret + + IL_0012: ldarg.0 + IL_0013: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::NewValueSome(!0) + IL_0018: ret + } + + .method public static int32 addWithActivePattern(int32 a, + int32 b) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationArgumentCountsAttribute::.ctor(int32[]) = ( 01 00 02 00 00 00 01 00 00 00 01 00 00 00 00 00 ) + + .maxstack 4 + .locals init (int32 V_0, + class [runtime]System.Exception V_1, + valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 V_2, + class [runtime]System.Exception V_3, + class [runtime]System.Exception V_4, + valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 V_5, + class [runtime]System.Exception V_6) + .try + { + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: div + IL_0003: stloc.0 + IL_0004: leave.s IL_005f + + } + filter + { + IL_0006: castclass [runtime]System.Exception + IL_000b: stloc.1 + IL_000c: ldloc.1 + IL_000d: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 ActivePatternTestCase::'|RecoverableException|_|'(class [runtime]System.Exception) + IL_0012: stloc.2 + IL_0013: ldloca.s V_2 + IL_0015: call instance int32 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_Tag() + IL_001a: ldc.i4.1 + IL_001b: bne.un.s IL_0028 + + IL_001d: ldloca.s V_2 + IL_001f: call instance !0 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_Item() + IL_0024: stloc.3 + IL_0025: ldc.i4.1 + IL_0026: br.s IL_0029 + + IL_0028: ldc.i4.0 + IL_0029: endfilter + } + { + IL_002b: castclass [runtime]System.Exception + IL_0030: stloc.s V_4 + IL_0032: ldloc.s V_4 + IL_0034: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 ActivePatternTestCase::'|RecoverableException|_|'(class [runtime]System.Exception) + IL_0039: stloc.s V_5 + IL_003b: ldloca.s V_5 + IL_003d: call instance int32 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_Tag() + IL_0042: ldc.i4.1 + IL_0043: bne.un.s IL_0054 + + IL_0045: ldloca.s V_5 + IL_0047: call instance !0 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_Item() + IL_004c: stloc.s V_6 + IL_004e: ldarg.0 + IL_004f: ldarg.1 + IL_0050: add + IL_0051: stloc.0 + IL_0052: leave.s IL_005f + + IL_0054: rethrow + IL_0056: ldnull + IL_0057: unbox.any [runtime]System.Int32 + IL_005c: stloc.0 + IL_005d: leave.s IL_005f + + } + IL_005f: ldloc.0 + IL_0060: ret + } + +} + +.class private abstract auto ansi sealed ''.$ActivePatternTestCase + extends [runtime]System.Object +{ + .method public static void main@() cil managed + { + .entrypoint + + .maxstack 8 + IL_0000: ret + } + +} + + + + + + diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs.il.bsl b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs.il.bsl new file mode 100644 index 00000000000..3dd52e246c0 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs.il.bsl @@ -0,0 +1,123 @@ + + + + + +.assembly extern runtime { } +.assembly extern FSharp.Core { } +.assembly assembly +{ + .hash algorithm 0x00008004 + .ver 0:0:0:0 +} +.module assembly.exe + +.imagebase {value} +.file alignment 0x00000200 +.stackreserve 0x00100000 +.subsystem 0x0003 +.corflags 0x00000001 + + + + + +.class public abstract auto ansi sealed ActivePatternTestCase + extends [runtime]System.Object +{ + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) + .method public specialname static valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 '|RecoverableException|_|'(class [runtime]System.Exception exn) cil managed + { + .param [0] + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.StructAttribute::.ctor() = ( 01 00 00 00 ) + + .maxstack 3 + .locals init (class [runtime]System.Exception V_0, + class [runtime]System.OperationCanceledException V_1) + IL_0000: ldarg.0 + IL_0001: stloc.0 + IL_0002: ldloc.0 + IL_0003: isinst [runtime]System.OperationCanceledException + IL_0008: stloc.1 + IL_0009: ldloc.1 + IL_000a: brfalse.s IL_0012 + + IL_000c: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_ValueNone() + IL_0011: ret + + IL_0012: ldarg.0 + IL_0013: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::NewValueSome(!0) + IL_0018: ret + } + + .method public static int32 addWithActivePattern(int32 a, + int32 b) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationArgumentCountsAttribute::.ctor(int32[]) = ( 01 00 02 00 00 00 01 00 00 00 01 00 00 00 00 00 ) + + .maxstack 4 + .locals init (int32 V_0, + class [runtime]System.Exception V_1, + valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 V_2, + class [runtime]System.Exception V_3) + .try + { + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: div + IL_0003: stloc.0 + IL_0004: leave.s IL_0036 + + } + catch [runtime]System.Object + { + IL_0006: castclass [runtime]System.Exception + IL_000b: stloc.1 + IL_000c: ldloc.1 + IL_000d: call valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1 ActivePatternTestCase::'|RecoverableException|_|'(class [runtime]System.Exception) + IL_0012: stloc.2 + IL_0013: ldloca.s V_2 + IL_0015: call instance int32 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_Tag() + IL_001a: ldc.i4.1 + IL_001b: bne.un.s IL_002b + + IL_001d: ldloca.s V_2 + IL_001f: call instance !0 valuetype [FSharp.Core]Microsoft.FSharp.Core.FSharpValueOption`1::get_Item() + IL_0024: stloc.3 + IL_0025: ldarg.0 + IL_0026: ldarg.1 + IL_0027: add + IL_0028: stloc.0 + IL_0029: leave.s IL_0036 + + IL_002b: rethrow + IL_002d: ldnull + IL_002e: unbox.any [runtime]System.Int32 + IL_0033: stloc.0 + IL_0034: leave.s IL_0036 + + } + IL_0036: ldloc.0 + IL_0037: ret + } + +} + +.class private abstract auto ansi sealed ''.$ActivePatternTestCase + extends [runtime]System.Object +{ + .method public static void main@() cil managed + { + .entrypoint + + .maxstack 8 + IL_0000: ret + } + +} + + + + + + diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/StackOverflowRepro.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/StackOverflowRepro.fs new file mode 100644 index 00000000000..310a6615aba --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/StackOverflowRepro.fs @@ -0,0 +1,34 @@ +module StackOverflowRepro +open System + +[] +let (|RecoverableException|_|) (exn: Exception) = + match exn with + | :? OperationCanceledException -> ValueNone + | _ -> + ValueSome exn + +let rec viaActivePattern (a:int) = + try + if a = 0 + then + raise (OperationCanceledException()) + else + viaActivePattern (a - 1) + with + | RecoverableException e -> + let x = struct(a,a,a,a) + let y = struct(x,a,x) + y.GetHashCode() + e.GetHashCode() + + + +[] +let main (args:string[]) = + let iterations = 4096 + try + viaActivePattern iterations + with + | ex -> + printf "%s" (ex.GetType().ToString()) + 0 \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryCatch.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryCatch.fs new file mode 100644 index 00000000000..9a43d34d429 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryCatch.fs @@ -0,0 +1,74 @@ +module EmittedIL.TryCatch + +open System.IO +open Xunit +open FSharp.Test +open FSharp.Test.Compiler + + +let setupCompilation compilation = + compilation + |> withOptions [ "--test:EmitFeeFeeAs100001" ] + |> withNoWarn 75 //The command-line option '--generate-filter-blocks' has been deprecated + |> withNoWarn 52 //The value has been copied to ensure the original is not mutated + |> asExe + |> withNoOptimize + |> withNoInterfaceData + |> withNoOptimizationData + |> withNoDebug + |> ignoreWarnings + +let verifyCompilation compilation = + setupCompilation compilation + |> verifyILBaseline + +[] +let ``TryCatch with active pattern`` compilation = + compilation + |> verifyCompilation + +[] +let ``TryCatch with active pattern and filter blocks switch`` compilation = + compilation + |> withOptions ["--generate-filter-blocks"] + |> verifyCompilation + +[] +let ``TryCatch with explicit guard`` compilation = + compilation + |> verifyCompilation + +[] +let ``TryCatch with explicit guard and filter blocks switch`` compilation = + compilation + |> withOptions ["--generate-filter-blocks"] + |> verifyCompilation + + +[] +let ``Stackoverflow reproduction`` compilation = + let compilationResult = + compilation + |> setupCompilation + // I cannot just `compileAndRun` this in process now, because it will crash entire test host. + |> compile + match compilationResult with + | CompilationResult.Success ({OutputPath = Some dllFile} as s) -> + let fsharpCoreFile = typeof>.Assembly.Location + File.Copy(fsharpCoreFile, Path.Combine(Path.GetDirectoryName(dllFile), Path.GetFileName(fsharpCoreFile)), true) + let exitCode, _stdout, _stderr = CompilerAssert.ExecuteAndReturnResult (dllFile, isFsx=false, deps = s.Dependencies, newProcess=true) + + Assert.NotEqual(0,exitCode) + + | _ -> failwith (sprintf "%A" compilationResult) + +[] +let ``Stackoverflow prevention`` compilation = + compilation + |> setupCompilation + |> withOptions ["--generate-filter-blocks"] + |> compileAndRun + |> shouldSucceed + |> verifyOutput "System.OperationCanceledException" + + \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs new file mode 100644 index 00000000000..24c975312bc --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs @@ -0,0 +1,9 @@ +module ExplicitGuardCase + +open System + +let addWithExplicitGuardInWithClause (a:int) (b:int) = + try + a / b + with + | anyOther when anyOther.GetType() <> typeof -> a + b \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs.generateFilterBlocks.il.bsl b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs.generateFilterBlocks.il.bsl new file mode 100644 index 00000000000..9b04438a731 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs.generateFilterBlocks.il.bsl @@ -0,0 +1,145 @@ + + + + + +.assembly extern runtime { } +.assembly extern FSharp.Core { } +.assembly extern netstandard +{ + .publickeytoken = (CC 7B 13 FF CD 2D DD 51 ) + .ver 2:1:0:0 +} +.assembly assembly +{ + .hash algorithm 0x00008004 + .ver 0:0:0:0 +} +.module assembly.exe + +.imagebase {value} +.file alignment 0x00000200 +.stackreserve 0x00100000 +.subsystem 0x0003 +.corflags 0x00000001 + + + + + +.class public abstract auto ansi sealed ExplicitGuardCase + extends [runtime]System.Object +{ + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) + .method public static int32 addWithExplicitGuardInWithClause(int32 a, + int32 b) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationArgumentCountsAttribute::.ctor(int32[]) = ( 01 00 02 00 00 00 01 00 00 00 01 00 00 00 00 00 ) + + .maxstack 4 + .locals init (int32 V_0, + class [runtime]System.Exception V_1, + class [runtime]System.Exception V_2, + class [runtime]System.Type V_3, + class [runtime]System.Type V_4, + class [runtime]System.Exception V_5, + class [runtime]System.Exception V_6, + class [runtime]System.Exception V_7, + class [runtime]System.Type V_8, + class [runtime]System.Type V_9, + class [runtime]System.Exception V_10) + .try + { + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: div + IL_0003: stloc.0 + IL_0004: leave IL_007d + + } + filter + { + IL_0009: castclass [runtime]System.Exception + IL_000e: stloc.1 + IL_000f: ldloc.1 + IL_0010: stloc.2 + IL_0011: ldloc.2 + IL_0012: callvirt instance class [runtime]System.Type [runtime]System.Exception::GetType() + IL_0017: stloc.3 + IL_0018: ldtoken [runtime]System.OperationCanceledException + IL_001d: call class [netstandard]System.Type [netstandard]System.Type::GetTypeFromHandle(valuetype [netstandard]System.RuntimeTypeHandle) + IL_0022: stloc.s V_4 + IL_0024: ldloc.3 + IL_0025: ldloc.s V_4 + IL_0027: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityIntrinsic(!!0, + !!0) + IL_002c: ldc.i4.0 + IL_002d: ceq + IL_002f: brfalse.s IL_0037 + + IL_0031: ldloc.1 + IL_0032: stloc.s V_5 + IL_0034: ldc.i4.1 + IL_0035: br.s IL_0038 + + IL_0037: ldc.i4.0 + IL_0038: endfilter + } + { + IL_003a: castclass [runtime]System.Exception + IL_003f: stloc.s V_6 + IL_0041: ldloc.s V_6 + IL_0043: stloc.s V_7 + IL_0045: ldloc.s V_7 + IL_0047: callvirt instance class [runtime]System.Type [runtime]System.Exception::GetType() + IL_004c: stloc.s V_8 + IL_004e: ldtoken [runtime]System.OperationCanceledException + IL_0053: call class [netstandard]System.Type [netstandard]System.Type::GetTypeFromHandle(valuetype [netstandard]System.RuntimeTypeHandle) + IL_0058: stloc.s V_9 + IL_005a: ldloc.s V_8 + IL_005c: ldloc.s V_9 + IL_005e: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityIntrinsic(!!0, + !!0) + IL_0063: ldc.i4.0 + IL_0064: ceq + IL_0066: brfalse.s IL_0072 + + IL_0068: ldloc.s V_6 + IL_006a: stloc.s V_10 + IL_006c: ldarg.0 + IL_006d: ldarg.1 + IL_006e: add + IL_006f: stloc.0 + IL_0070: leave.s IL_007d + + IL_0072: rethrow + IL_0074: ldnull + IL_0075: unbox.any [runtime]System.Int32 + IL_007a: stloc.0 + IL_007b: leave.s IL_007d + + } + IL_007d: ldloc.0 + IL_007e: ret + } + +} + +.class private abstract auto ansi sealed ''.$ExplicitGuardCase + extends [runtime]System.Object +{ + .method public static void main@() cil managed + { + .entrypoint + + .maxstack 8 + IL_0000: ret + } + +} + + + + + + diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs.il.bsl b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs.il.bsl new file mode 100644 index 00000000000..7aff9be8c6a --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/TryWithExplicitGuard.fs.il.bsl @@ -0,0 +1,113 @@ + + + + + +.assembly extern runtime { } +.assembly extern FSharp.Core { } +.assembly extern netstandard +{ + .publickeytoken = (CC 7B 13 FF CD 2D DD 51 ) + .ver 2:1:0:0 +} +.assembly assembly +{ + .hash algorithm 0x00008004 + .ver 0:0:0:0 +} +.module assembly.exe + +.imagebase {value} +.file alignment 0x00000200 +.stackreserve 0x00100000 +.subsystem 0x0003 +.corflags 0x00000001 + + + + + +.class public abstract auto ansi sealed ExplicitGuardCase + extends [runtime]System.Object +{ + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) + .method public static int32 addWithExplicitGuardInWithClause(int32 a, + int32 b) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationArgumentCountsAttribute::.ctor(int32[]) = ( 01 00 02 00 00 00 01 00 00 00 01 00 00 00 00 00 ) + + .maxstack 4 + .locals init (int32 V_0, + class [runtime]System.Exception V_1, + class [runtime]System.Exception V_2, + class [runtime]System.Type V_3, + class [runtime]System.Type V_4, + class [runtime]System.Exception V_5) + .try + { + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: div + IL_0003: stloc.0 + IL_0004: leave.s IL_0042 + + } + catch [runtime]System.Object + { + IL_0006: castclass [runtime]System.Exception + IL_000b: stloc.1 + IL_000c: ldloc.1 + IL_000d: stloc.2 + IL_000e: ldloc.2 + IL_000f: callvirt instance class [runtime]System.Type [runtime]System.Exception::GetType() + IL_0014: stloc.3 + IL_0015: ldtoken [runtime]System.OperationCanceledException + IL_001a: call class [netstandard]System.Type [netstandard]System.Type::GetTypeFromHandle(valuetype [netstandard]System.RuntimeTypeHandle) + IL_001f: stloc.s V_4 + IL_0021: ldloc.3 + IL_0022: ldloc.s V_4 + IL_0024: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityIntrinsic(!!0, + !!0) + IL_0029: ldc.i4.0 + IL_002a: ceq + IL_002c: brfalse.s IL_0037 + + IL_002e: ldloc.1 + IL_002f: stloc.s V_5 + IL_0031: ldarg.0 + IL_0032: ldarg.1 + IL_0033: add + IL_0034: stloc.0 + IL_0035: leave.s IL_0042 + + IL_0037: rethrow + IL_0039: ldnull + IL_003a: unbox.any [runtime]System.Int32 + IL_003f: stloc.0 + IL_0040: leave.s IL_0042 + + } + IL_0042: ldloc.0 + IL_0043: ret + } + +} + +.class private abstract auto ansi sealed ''.$ExplicitGuardCase + extends [runtime]System.Object +{ + .method public static void main@() cil managed + { + .entrypoint + + .maxstack 8 + IL_0000: ret + } + +} + + + + + + diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 5c79022dc03..5f352a315ee 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -181,6 +181,7 @@ +