From ca6d9dbfd6e0531de67f67dacae5efd6fa4fff98 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Mon, 8 Apr 2024 15:36:56 +0200 Subject: [PATCH 1/2] Fix StackOverflow in big-ish nested CEs --- .../Checking/CheckComputationExpressions.fs | 144 +++++++++--------- 1 file changed, 73 insertions(+), 71 deletions(-) diff --git a/src/Compiler/Checking/CheckComputationExpressions.fs b/src/Compiler/Checking/CheckComputationExpressions.fs index 3384b247b1f..2abf219d808 100644 --- a/src/Compiler/Checking/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/CheckComputationExpressions.fs @@ -2596,83 +2596,85 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol trans CompExprTranslationPass.Initial CustomOperationsMode.Denied emptyVarSpace comp id and trans firstTry q varSpace comp translatedCtxt = - match tryTrans firstTry q varSpace comp translatedCtxt with - | Some e -> e - | None -> - // This only occurs in final position in a sequence - match comp with - // "do! expr;" in final position is treated as { let! () = expr in return () } when Return is provided (and no Zero with Default attribute is available) or as { let! () = expr in zero } otherwise - | SynExpr.DoBang(rhsExpr, m) -> - let mUnit = rhsExpr.Range - let rhsExpr = mkSourceExpr rhsExpr + cenv.stackGuard.Guard + <| fun () -> + match tryTrans firstTry q varSpace comp translatedCtxt with + | Some e -> e + | None -> + // This only occurs in final position in a sequence + match comp with + // "do! expr;" in final position is treated as { let! () = expr in return () } when Return is provided (and no Zero with Default attribute is available) or as { let! () = expr in zero } otherwise + | SynExpr.DoBang(rhsExpr, m) -> + let mUnit = rhsExpr.Range + let rhsExpr = mkSourceExpr rhsExpr - if isQuery then - error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), m)) + if isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), m)) - let bodyExpr = - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy + let bodyExpr = + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy + ) + then + SynExpr.ImplicitZero m + else + match + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy + with + | minfo :: _ when MethInfoHasAttribute cenv.g m cenv.g.attrib_DefaultValueAttribute minfo -> SynExpr.ImplicitZero m + | _ -> SynExpr.YieldOrReturn((false, true), SynExpr.Const(SynConst.Unit, m), m) + + let letBangBind = + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtDo, + false, + false, + SynPat.Const(SynConst.Unit, mUnit), + rhsExpr, + [], + bodyExpr, + m, + SynExprLetOrUseBangTrivia.Zero ) - then - SynExpr.ImplicitZero m - else - match - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy - with - | minfo :: _ when MethInfoHasAttribute cenv.g m cenv.g.attrib_DefaultValueAttribute minfo -> SynExpr.ImplicitZero m - | _ -> SynExpr.YieldOrReturn((false, true), SynExpr.Const(SynConst.Unit, m), m) - - let letBangBind = - SynExpr.LetOrUseBang( - DebugPointAtBinding.NoneAtDo, - false, - false, - SynPat.Const(SynConst.Unit, mUnit), - rhsExpr, - [], - bodyExpr, - m, - SynExprLetOrUseBangTrivia.Zero - ) - trans CompExprTranslationPass.Initial q varSpace letBangBind translatedCtxt + trans CompExprTranslationPass.Initial q varSpace letBangBind translatedCtxt - // "expr;" in final position is treated as { expr; zero } - // Suppress the sequence point on the "zero" - | _ -> - // Check for 'where x > y' and other mis-applications of infix operators. If detected, give a good error message, and just ignore comp - if isQuery && checkForBinaryApp comp then - trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) translatedCtxt - else - if isQuery && not comp.IsArbExprAndThusAlreadyReportedError then - match comp with - | SynExpr.JoinIn _ -> () // an error will be reported later when we process innerComp1 as a sequential - | _ -> errorR (Error(FSComp.SR.tcUnrecognizedQueryOperator (), comp.RangeOfFirstPortion)) - - trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) (fun holeFill -> - let fillExpr = - if enableImplicitYield then - let implicitYieldExpr = mkSynCall "Yield" comp.Range [ comp ] - - SynExpr.SequentialOrImplicitYield( - DebugPointAtSequential.SuppressExpr, - comp, - holeFill, - implicitYieldExpr, - comp.Range - ) - else - SynExpr.Sequential( - DebugPointAtSequential.SuppressExpr, - true, - comp, - holeFill, - comp.Range, - SynExprSequentialTrivia.Zero - ) + // "expr;" in final position is treated as { expr; zero } + // Suppress the sequence point on the "zero" + | _ -> + // Check for 'where x > y' and other mis-applications of infix operators. If detected, give a good error message, and just ignore comp + if isQuery && checkForBinaryApp comp then + trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) translatedCtxt + else + if isQuery && not comp.IsArbExprAndThusAlreadyReportedError then + match comp with + | SynExpr.JoinIn _ -> () // an error will be reported later when we process innerComp1 as a sequential + | _ -> errorR (Error(FSComp.SR.tcUnrecognizedQueryOperator (), comp.RangeOfFirstPortion)) + + trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) (fun holeFill -> + let fillExpr = + if enableImplicitYield then + let implicitYieldExpr = mkSynCall "Yield" comp.Range [ comp ] + + SynExpr.SequentialOrImplicitYield( + DebugPointAtSequential.SuppressExpr, + comp, + holeFill, + implicitYieldExpr, + comp.Range + ) + else + SynExpr.Sequential( + DebugPointAtSequential.SuppressExpr, + true, + comp, + holeFill, + comp.Range, + SynExprSequentialTrivia.Zero + ) - translatedCtxt fillExpr) + translatedCtxt fillExpr) and transBind q varSpace bindRange addBindDebugPoint bindName bindArgs (consumePat: SynPat) (innerComp: SynExpr) translatedCtxt = From 368e4e4e767eb09f5fbce22e4199f13e9713e385 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 8 Apr 2024 14:41:02 +0000 Subject: [PATCH 2/2] Automated command ran: fantomas Co-authored-by: vzarytovskii <1260985+vzarytovskii@users.noreply.github.com> --- src/Compiler/Checking/CheckComputationExpressions.fs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Checking/CheckComputationExpressions.fs b/src/Compiler/Checking/CheckComputationExpressions.fs index 2abf219d808..2aa454f9508 100644 --- a/src/Compiler/Checking/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/CheckComputationExpressions.fs @@ -2614,7 +2614,14 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let bodyExpr = if isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + m + ad + "Return" + builderTy ) then SynExpr.ImplicitZero m @@ -2622,7 +2629,8 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy with - | minfo :: _ when MethInfoHasAttribute cenv.g m cenv.g.attrib_DefaultValueAttribute minfo -> SynExpr.ImplicitZero m + | minfo :: _ when MethInfoHasAttribute cenv.g m cenv.g.attrib_DefaultValueAttribute minfo -> + SynExpr.ImplicitZero m | _ -> SynExpr.YieldOrReturn((false, true), SynExpr.Const(SynConst.Unit, m), m) let letBangBind =