Skip to content

Commit 20e794d

Browse files
T-GroT-Gro
authored
Address StackOverflowExceptions in typechecking (#17654)
1 parent 67f160c commit 20e794d

15 files changed

+786
-111
lines changed

‎docs/release-notes/.FSharp.Compiler.Service/9.0.100.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@
1616
* Parentheses analysis: keep extra parentheses around unit & tuples in method definitions. ([PR #17618](https://github.com/dotnet/fsharp/pull/17618))
1717
* Fix IsUnionCaseTester throwing for non-methods/properties [#17301](https://github.com/dotnet/fsharp/pull/17634)
1818
* 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))
19+
* Guard for possible StackOverflowException when typechecking non recursive modules and namespaces ([PR #17654](https://github.com/dotnet/fsharp/pull/17654))
1920

2021
### Added
2122

‎src/Compiler/Checking/CheckDeclarations.fs‎

Lines changed: 112 additions & 108 deletions
Original file line numberDiff line numberDiff line change
@@ -5113,8 +5113,106 @@ let CheckLetOrDoInNamespace binds m =
51135113
| _ ->
51145114
error(Error(FSComp.SR.tcNamespaceCannotContainValues(), binds.Head.RangeOfHeadPattern))
51155115

5116+
let rec TcMutRecDefsFinish cenv defs m =
5117+
let opens =
5118+
[ for def in defs do
5119+
match def with
5120+
| MutRecShape.Open (MutRecDataForOpen (_target, _m, _moduleRange, openDeclsRef)) ->
5121+
yield! openDeclsRef.Value
5122+
| _ -> () ]
5123+
5124+
let tycons = defs |> List.choose (function MutRecShape.Tycon (Some tycon, _) -> Some tycon | _ -> None)
5125+
5126+
let binds =
5127+
defs |> List.collect (function
5128+
| MutRecShape.Open _ -> []
5129+
| MutRecShape.ModuleAbbrev _ -> []
5130+
| MutRecShape.Tycon (_, binds)
5131+
| MutRecShape.Lets binds ->
5132+
binds |> List.map ModuleOrNamespaceBinding.Binding
5133+
| MutRecShape.Module ((MutRecDefnsPhase2DataForModule(moduleTyAcc, moduleEntity), _), moduleDefs) ->
5134+
let moduleContents = TcMutRecDefsFinish cenv moduleDefs m
5135+
moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value
5136+
[ ModuleOrNamespaceBinding.Module(moduleEntity, moduleContents) ])
5137+
5138+
TMDefRec(true, opens, tycons, binds, m)
5139+
5140+
/// The mutually recursive case for a sequence of declarations (and nested modules)
5141+
let TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial mutRecNSInfo (defs: SynModuleDecl list) =
5142+
let m = match defs with [] -> m | _ -> defs |> List.map (fun d -> d.Range) |> List.reduce unionRanges
5143+
let scopem = (defs, m) ||> List.foldBack (fun h m -> unionRanges h.Range m)
5144+
5145+
let mutRecDefns, (_, _, Attributes synAttrs) =
5146+
let rec loop isNamespace moduleRange attrs defs: MutRecDefnsInitialData * _ =
5147+
((true, true, attrs), defs) ||> List.collectFold (fun (openOk, moduleAbbrevOk, attrs) def ->
5148+
match ElimSynModuleDeclExpr def with
5149+
5150+
| SynModuleDecl.Types (typeDefs, _) ->
5151+
let decls = typeDefs |> List.map MutRecShape.Tycon
5152+
decls, (false, false, attrs)
5153+
5154+
| SynModuleDecl.Let (letrec, binds, m) ->
5155+
let binds =
5156+
if isNamespace then
5157+
CheckLetOrDoInNamespace binds m; []
5158+
else
5159+
if letrec then [MutRecShape.Lets binds]
5160+
else List.map (List.singleton >> MutRecShape.Lets) binds
5161+
binds, (false, false, attrs)
5162+
5163+
| SynModuleDecl.NestedModule(moduleInfo = (SynComponentInfo(longId = []))) ->
5164+
[], (openOk, moduleAbbrevOk, attrs)
5165+
5166+
| SynModuleDecl.NestedModule(moduleInfo=compInfo; isRecursive=isRec; decls=synDefs; range=moduleRange) ->
5167+
if isRec then warning(Error(FSComp.SR.tcRecImplied(), compInfo.Range))
5168+
let mutRecDefs, (_, _, attrs) = loop false moduleRange attrs synDefs
5169+
let decls = [MutRecShape.Module (compInfo, mutRecDefs)]
5170+
decls, (false, false, attrs)
5171+
5172+
| SynModuleDecl.Open (target, m) ->
5173+
if not openOk then errorR(Error(FSComp.SR.tcOpenFirstInMutRec(), m))
5174+
let decls = [ MutRecShape.Open (MutRecDataForOpen(target, m, moduleRange, ref [])) ]
5175+
decls, (openOk, moduleAbbrevOk, attrs)
5176+
5177+
| SynModuleDecl.Exception (SynExceptionDefn(repr, _, members, _), _m) ->
5178+
let members = desugarGetSetMembers members
5179+
let (SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _repr, xmlDoc, vis, m)) = repr
5180+
let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange)
5181+
let decls = [ MutRecShape.Tycon(SynTypeDefn(compInfo, SynTypeDefnRepr.Exception repr, members, None, m, SynTypeDefnTrivia.Zero)) ]
5182+
decls, (false, false, attrs)
5183+
5184+
| SynModuleDecl.HashDirective _ ->
5185+
[ ], (openOk, moduleAbbrevOk, attrs)
5186+
5187+
| SynModuleDecl.Attributes (synAttrs, _) ->
5188+
[ ], (false, false, synAttrs)
5189+
5190+
| SynModuleDecl.ModuleAbbrev (id, p, m) ->
5191+
if not moduleAbbrevOk then errorR(Error(FSComp.SR.tcModuleAbbrevFirstInMutRec(), m))
5192+
let decls = [ MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev(id, p, m)) ]
5193+
decls, (false, moduleAbbrevOk, attrs)
5194+
5195+
| SynModuleDecl.Expr _ -> failwith "unreachable: SynModuleDecl.Expr - ElimSynModuleDeclExpr"
5196+
5197+
| SynModuleDecl.NamespaceFragment _ as d -> error(Error(FSComp.SR.tcUnsupportedMutRecDecl(), d.Range)))
5198+
5199+
loop (match parent with ParentNone -> true | Parent _ -> false) m [] defs
5200+
5201+
let tpenv = emptyUnscopedTyparEnv
5202+
let mutRecDefnsChecked, envAfter = TcDeclarations.TcMutRecDefinitions cenv envInitial parent typeNames tpenv m scopem mutRecNSInfo mutRecDefns true
5203+
5204+
// Check the assembly attributes
5205+
let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs
5206+
5207+
// Check the non-escaping condition as we build the list of module expressions on the way back up
5208+
let moduleContents = TcMutRecDefsFinish cenv mutRecDefnsChecked m
5209+
let escapeCheck () =
5210+
TcMutRecDefnsEscapeCheck mutRecDefnsChecked envInitial
5211+
5212+
([ moduleContents ], [ escapeCheck ], attrs), envAfter, envAfter
5213+
51165214
/// The non-mutually recursive case for a declaration
5117-
let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem env synDecl =
5215+
let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem env synDecl =
51185216
cancellable {
51195217
let g = cenv.g
51205218
cenv.synArgNameGenerator.Reset()
@@ -5196,7 +5294,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
51965294
if isRec then
51975295
assert (not isContinuingModule)
51985296
let modDecl = SynModuleDecl.NestedModule(compInfo, false, moduleDefs, isContinuingModule, m, trivia)
5199-
return! TcModuleOrNamespaceElementsMutRec cenv parent typeNames m env None [modDecl]
5297+
return TcModuleOrNamespaceElementsMutRec cenv parent typeNames m env None [modDecl]
52005298
else
52015299
let (SynComponentInfo(Attributes attribs, _, _, longPath, xml, _, vis, im)) = compInfo
52025300
let id = ComputeModuleName longPath
@@ -5224,7 +5322,9 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
52245322
let moduleEntity = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id xmlDoc modAttrs (MaybeLazy.Strict moduleTy)
52255323

52265324
// Now typecheck.
5227-
let! moduleContents, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef moduleEntity)) endm envForModule xml None [] moduleDefs
5325+
let! moduleContents, topAttrsNew, envAtEnd =
5326+
TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef moduleEntity)) endm envForModule xml None [] moduleDefs
5327+
|> cenv.stackGuard.GuardCancellable
52285328

52295329
// Get the inferred type of the decls and record it in the modul.
52305330
moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value
@@ -5313,7 +5413,9 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
53135413
let nsInfo = Some (modulNSOpt, envNS.eModuleOrNamespaceTypeAccumulator)
53145414
let mutRecNSInfo = if isRec then nsInfo else None
53155415

5316-
let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs
5416+
let! moduleContents, topAttrs, envAtEnd =
5417+
TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs
5418+
|> cenv.stackGuard.GuardCancellable
53175419

53185420
MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo
53195421
let env, openDecls =
@@ -5365,115 +5467,14 @@ and [<TailCall>] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm
53655467
else
53665468
unionRanges (List.head otherDefs).Range endm
53675469

5368-
let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef)
5470+
let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef |> cenv.stackGuard.GuardCancellable)
53695471

53705472
match result with
53715473
| ValueOrCancelled.Cancelled x ->
53725474
ValueOrCancelled.Cancelled x
53735475
| ValueOrCancelled.Value(firstDef, env, envAtEnd) ->
53745476
TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ((firstDef :: defsSoFar), env, envAtEnd) otherDefs ct
53755477

5376-
/// The mutually recursive case for a sequence of declarations (and nested modules)
5377-
and TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial mutRecNSInfo (defs: SynModuleDecl list) =
5378-
cancellable {
5379-
5380-
let m = match defs with [] -> m | _ -> defs |> List.map (fun d -> d.Range) |> List.reduce unionRanges
5381-
let scopem = (defs, m) ||> List.foldBack (fun h m -> unionRanges h.Range m)
5382-
5383-
let mutRecDefns, (_, _, Attributes synAttrs) =
5384-
let rec loop isNamespace moduleRange attrs defs: MutRecDefnsInitialData * _ =
5385-
((true, true, attrs), defs) ||> List.collectFold (fun (openOk, moduleAbbrevOk, attrs) def ->
5386-
match ElimSynModuleDeclExpr def with
5387-
5388-
| SynModuleDecl.Types (typeDefs, _) ->
5389-
let decls = typeDefs |> List.map MutRecShape.Tycon
5390-
decls, (false, false, attrs)
5391-
5392-
| SynModuleDecl.Let (letrec, binds, m) ->
5393-
let binds =
5394-
if isNamespace then
5395-
CheckLetOrDoInNamespace binds m; []
5396-
else
5397-
if letrec then [MutRecShape.Lets binds]
5398-
else List.map (List.singleton >> MutRecShape.Lets) binds
5399-
binds, (false, false, attrs)
5400-
5401-
| SynModuleDecl.NestedModule(moduleInfo = (SynComponentInfo(longId = []))) ->
5402-
[], (openOk, moduleAbbrevOk, attrs)
5403-
5404-
| SynModuleDecl.NestedModule(moduleInfo=compInfo; isRecursive=isRec; decls=synDefs; range=moduleRange) ->
5405-
if isRec then warning(Error(FSComp.SR.tcRecImplied(), compInfo.Range))
5406-
let mutRecDefs, (_, _, attrs) = loop false moduleRange attrs synDefs
5407-
let decls = [MutRecShape.Module (compInfo, mutRecDefs)]
5408-
decls, (false, false, attrs)
5409-
5410-
| SynModuleDecl.Open (target, m) ->
5411-
if not openOk then errorR(Error(FSComp.SR.tcOpenFirstInMutRec(), m))
5412-
let decls = [ MutRecShape.Open (MutRecDataForOpen(target, m, moduleRange, ref [])) ]
5413-
decls, (openOk, moduleAbbrevOk, attrs)
5414-
5415-
| SynModuleDecl.Exception (SynExceptionDefn(repr, _, members, _), _m) ->
5416-
let members = desugarGetSetMembers members
5417-
let (SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _repr, xmlDoc, vis, m)) = repr
5418-
let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange)
5419-
let decls = [ MutRecShape.Tycon(SynTypeDefn(compInfo, SynTypeDefnRepr.Exception repr, members, None, m, SynTypeDefnTrivia.Zero)) ]
5420-
decls, (false, false, attrs)
5421-
5422-
| SynModuleDecl.HashDirective _ ->
5423-
[ ], (openOk, moduleAbbrevOk, attrs)
5424-
5425-
| SynModuleDecl.Attributes (synAttrs, _) ->
5426-
[ ], (false, false, synAttrs)
5427-
5428-
| SynModuleDecl.ModuleAbbrev (id, p, m) ->
5429-
if not moduleAbbrevOk then errorR(Error(FSComp.SR.tcModuleAbbrevFirstInMutRec(), m))
5430-
let decls = [ MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev(id, p, m)) ]
5431-
decls, (false, moduleAbbrevOk, attrs)
5432-
5433-
| SynModuleDecl.Expr _ -> failwith "unreachable: SynModuleDecl.Expr - ElimSynModuleDeclExpr"
5434-
5435-
| SynModuleDecl.NamespaceFragment _ as d -> error(Error(FSComp.SR.tcUnsupportedMutRecDecl(), d.Range)))
5436-
5437-
loop (match parent with ParentNone -> true | Parent _ -> false) m [] defs
5438-
5439-
let tpenv = emptyUnscopedTyparEnv
5440-
let mutRecDefnsChecked, envAfter = TcDeclarations.TcMutRecDefinitions cenv envInitial parent typeNames tpenv m scopem mutRecNSInfo mutRecDefns true
5441-
5442-
// Check the assembly attributes
5443-
let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs
5444-
5445-
// Check the non-escaping condition as we build the list of module expressions on the way back up
5446-
let moduleContents = TcMutRecDefsFinish cenv mutRecDefnsChecked m
5447-
let escapeCheck () =
5448-
TcMutRecDefnsEscapeCheck mutRecDefnsChecked envInitial
5449-
5450-
return ([ moduleContents ], [ escapeCheck ], attrs), envAfter, envAfter
5451-
5452-
}
5453-
5454-
and TcMutRecDefsFinish cenv defs m =
5455-
let opens =
5456-
[ for def in defs do
5457-
match def with
5458-
| MutRecShape.Open (MutRecDataForOpen (_target, _m, _moduleRange, openDeclsRef)) ->
5459-
yield! openDeclsRef.Value
5460-
| _ -> () ]
5461-
5462-
let tycons = defs |> List.choose (function MutRecShape.Tycon (Some tycon, _) -> Some tycon | _ -> None)
5463-
5464-
let binds =
5465-
defs |> List.collect (function
5466-
| MutRecShape.Open _ -> []
5467-
| MutRecShape.ModuleAbbrev _ -> []
5468-
| MutRecShape.Tycon (_, binds)
5469-
| MutRecShape.Lets binds ->
5470-
binds |> List.map ModuleOrNamespaceBinding.Binding
5471-
| MutRecShape.Module ((MutRecDefnsPhase2DataForModule(moduleTyAcc, moduleEntity), _), moduleDefs) ->
5472-
let moduleContents = TcMutRecDefsFinish cenv moduleDefs m
5473-
moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value
5474-
[ ModuleOrNamespaceBinding.Module(moduleEntity, moduleContents) ])
5475-
5476-
TMDefRec(true, opens, tycons, binds, m)
54775478

54785479
and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 synModuleDecls =
54795480
cancellable {
@@ -5488,7 +5489,8 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0
54885489

54895490
match mutRecNSInfo with
54905491
| Some _ ->
5491-
let! (moduleDefs, escapeChecks, topAttrsNew), _, envAtEnd = TcModuleOrNamespaceElementsMutRec cenv parent typeNames endm env mutRecNSInfo synModuleDecls
5492+
let (moduleDefs, escapeChecks, topAttrsNew), _, envAtEnd =
5493+
TcModuleOrNamespaceElementsMutRec cenv parent typeNames endm env mutRecNSInfo synModuleDecls
54925494
let moduleContents = TMDefs(moduleDefs)
54935495
// Run the escape checks (for compat run in reverse order)
54945496
do
@@ -5746,7 +5748,9 @@ let CheckOneImplFile
57465748
let envinner, moduleTyAcc = MakeInitialEnv env
57475749

57485750
let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment x ]
5749-
let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs
5751+
let! moduleContents, topAttrs, envAtEnd =
5752+
TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs
5753+
|> cenv.stackGuard.GuardCancellable
57505754

57515755
let implFileTypePriorToSig = moduleTyAcc.Value
57525756

‎src/Compiler/Driver/CompilerConfig.fs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -473,7 +473,8 @@ type TcConfigBuilder =
473473
mutable printAllSignatureFiles: bool
474474
mutable xmlDocOutputFile: string option
475475
mutable stats: bool
476-
mutable generateFilterBlocks: bool (* don't generate filter blocks due to bugs on Mono *)
476+
mutable generateFilterBlocks:
477+
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 *)
477478

478479
mutable signer: string option
479480
mutable container: string option
@@ -717,7 +718,7 @@ type TcConfigBuilder =
717718
printAllSignatureFiles = false
718719
xmlDocOutputFile = None
719720
stats = false
720-
generateFilterBlocks = false (* don't generate filter blocks *)
721+
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. *)
721722

722723
signer = None
723724
container = None

‎src/Compiler/FSharp.Compiler.Service.fsproj‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,9 @@
3030
<OtherFlags>$(OtherFlags) --warnon:3218</OtherFlags>
3131
<!-- 3390: xmlDocBadlyFormed -->
3232
<OtherFlags>$(OtherFlags) --warnon:3390</OtherFlags>
33-
<Tailcalls>true</Tailcalls> <!-- .tail annotations always emitted for this binary, even in debug mode -->
33+
<!-- generate IL filter blocks in order to prevent StackOverFlowException in TcExpr guarded with |RecoverableException| active pattern-->
34+
<OtherFlags>$(OtherFlags) --generate-filter-blocks</OtherFlags>
35+
<Tailcalls>true</Tailcalls> <!-- .tail annotations always emitted for this binary, even in debug mode -->
3436
<FsYaccOutputFolder>$(IntermediateOutputPath)$(TargetFramework)\</FsYaccOutputFolder>
3537
<FsLexOutputFolder>$(IntermediateOutputPath)$(TargetFramework)\</FsLexOutputFolder>
3638
<EnableDefaultEmbeddedResourceItems>false</EnableDefaultEmbeddedResourceItems>

‎src/Compiler/Facilities/DiagnosticsLogger.fs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -903,6 +903,10 @@ type StackGuard(maxDepth: int, name: string) =
903903
finally
904904
depth <- depth - 1
905905

906+
[<DebuggerHidden; DebuggerStepThrough>]
907+
member x.GuardCancellable(original: Cancellable<'T>) =
908+
Cancellable(fun ct -> x.Guard(fun () -> Cancellable.run ct original))
909+
906910
static member val DefaultDepth =
907911
#if DEBUG
908912
GetEnvInteger "FSHARP_DefaultStackGuardDepth" 50

‎src/Compiler/Facilities/DiagnosticsLogger.fsi‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -462,6 +462,8 @@ type StackGuard =
462462
[<CallerLineNumber; Optional; DefaultParameterValue(0)>] line: int ->
463463
'T
464464

465+
member GuardCancellable: Internal.Utilities.Library.Cancellable<'T> -> Internal.Utilities.Library.Cancellable<'T>
466+
465467
static member GetDepthOption: string -> int
466468

467469
/// This represents the global state established as each task function runs as part of the build.

‎tests/FSharp.Compiler.ComponentTests/EmittedIL/TryCatch/ActivePatternRecoverableException.fs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
module ActivePatternTestCase
2+
3+
open System
4+
5+
[<return: Struct>]
6+
let (|RecoverableException|_|) (exn: Exception) =
7+
match exn with
8+
| :? OperationCanceledException -> ValueNone
9+
| _ ->
10+
ValueSome exn
11+
12+
let addWithActivePattern (a:int) (b:int) =
13+
try
14+
a / b
15+
with
16+
| RecoverableException e -> a + b

0 commit comments

Comments
 (0)