diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs
index 52e404cea3e..2fcab81b195 100644
--- a/src/Compiler/Optimize/Optimizer.fs
+++ b/src/Compiler/Optimize/Optimizer.fs
@@ -36,6 +36,61 @@ open System.Collections.ObjectModel
let OptimizerStackGuardDepth = GetEnvInteger "FSHARP_Optimizer" 50
+//-------------------------------------------------------------------------
+// Cheap "occurs" checks (avoid full free-variable set construction)
+//-------------------------------------------------------------------------
+
+let rec private ExprUsesLocal (v: Val) (expr: Expr) =
+ // Be robust against reclinks and wrappers
+ let expr = stripExpr expr
+ match expr with
+ | Expr.Val (VRefLocal v2, _, _) -> valEq v v2
+ | Expr.App (f, _, _, args, _) ->
+ ExprUsesLocal v f || List.exists (ExprUsesLocal v) args
+ | Expr.Lambda (_, _, _, _, body, _, _)
+ | Expr.TyLambda (_, _, body, _, _) ->
+ ExprUsesLocal v body
+ | Expr.StaticOptimization (_, e2, e3, _) ->
+ ExprUsesLocal v e2 || ExprUsesLocal v e3
+ | Expr.TyChoose _ ->
+ // Conservative: free-choice typars inside; assume potential use
+ true
+ | Expr.Quote _ ->
+ // Conservative: quotations can capture locals
+ true
+ | Expr.Let (TBind (_, e1, _), e2, _, _) ->
+ ExprUsesLocal v e1 || ExprUsesLocal v e2
+ | Expr.LetRec (binds, body, _, _) ->
+ List.exists (fun (TBind (_, e, _)) -> ExprUsesLocal v e) binds || ExprUsesLocal v body
+ | Expr.Sequential (e1, e2, _, _) ->
+ ExprUsesLocal v e1 || ExprUsesLocal v e2
+ | Expr.Match (_, _, dtree, targets, _, _) ->
+ DecisionTreeUsesLocal v dtree ||
+ Array.exists (fun (TTarget (_, e, _)) -> ExprUsesLocal v e) targets
+ // IMPORTANT: account for address-of locals (e.g., passing out-byref) which carry the ValRef in the op payload
+ | Expr.Op (TOp.LValueOp (LAddrOf _, lv), _, _, _) ->
+ valEq v lv.Deref
+ | Expr.Op (_, _, args, _) ->
+ List.exists (ExprUsesLocal v) args
+ | Expr.Obj (_, _, _, ctorCall, overrides, iimpls, _) ->
+ ExprUsesLocal v ctorCall ||
+ List.exists (fun (TObjExprMethod (_, _, _, _, e, _)) -> ExprUsesLocal v e) overrides ||
+ List.exists (fun (_, ms) -> List.exists (fun (TObjExprMethod (_, _, _, _, e, _)) -> ExprUsesLocal v e) ms) iimpls
+ | Expr.DebugPoint (_, e) ->
+ ExprUsesLocal v e
+ | _ -> false
+
+and private DecisionTreeUsesLocal (v: Val) (dt: DecisionTree) =
+ match dt with
+ | TDSuccess (es, _) ->
+ List.exists (ExprUsesLocal v) es
+ | TDBind (TBind (_, e1, _), rest) ->
+ ExprUsesLocal v e1 || DecisionTreeUsesLocal v rest
+ | TDSwitch (e, cases, dflt, _) ->
+ ExprUsesLocal v e ||
+ List.exists (fun (TCase (_, t)) -> DecisionTreeUsesLocal v t) cases ||
+ Option.exists (DecisionTreeUsesLocal v) dflt
+
let i_ldlen = [ I_ldlen; (AI_conv DT_I4) ]
/// size of a function call
@@ -1706,9 +1761,7 @@ let TryEliminateBinding cenv _env bind e2 _m =
// But note the cases below cover some instances of side-effecting expressions as well....
let IsUniqueUse vspec2 args =
valEq vspec1 vspec2
- // REVIEW: this looks slow. Look only for one variable instead
- && (let fvs = accFreeInExprs (CollectLocalsWithStackGuard()) args emptyFreeVars
- not (Zset.contains vspec1 fvs.FreeLocals))
+ && not (List.exists (ExprUsesLocal vspec1) args)
// Immediate consumption of value as 2nd or subsequent argument to a construction or projection operation
let rec GetImmediateUseContext rargsl argsr =
@@ -1742,8 +1795,12 @@ let TryEliminateBinding cenv _env bind e2 _m =
// Immediate consumption of value by a pattern match 'let x = e in match x with ...'
| Expr.Match (spMatch, _exprm, TDSwitch(DebugPoints(Expr.Val (VRefLocal vspec2, _, _), recreate1), cases, dflt, _), targets, m, ty2)
when (valEq vspec1 vspec2 &&
- let fvs = accFreeInTargets CollectLocals targets (accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars)
- not (Zset.contains vspec1 fvs.FreeLocals)) ->
+ let fvsContains =
+ let fvTargets = accFreeInTargets CollectLocals targets emptyFreeVars
+ let fvCases = accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars
+ let fvs = unionFreeVars fvTargets fvCases
+ Zset.contains vspec1 fvs.FreeLocals
+ not fvsContains) ->
let spMatch = spBind.Combine spMatch
Some (Expr.Match (spMatch, e1.Range, TDSwitch(recreate1 e1, cases, dflt, m), targets, m, ty2) |> recreate0)
@@ -2896,12 +2953,25 @@ and OptimizeLinearExpr cenv env expr contf =
| Expr.Let (bind, body, m, _) ->
- let (bindR, bindingInfo), env = OptimizeBinding cenv false env bind
+ let (bindR: Binding, bindingInfo), env = OptimizeBinding cenv false env bind
OptimizeLinearExpr cenv env body (contf << (fun (bodyR, bodyInfo) ->
- // PERF: This call to ValueIsUsedOrHasEffect/freeInExpr amounts to 9% of all optimization time.
- // Is it quadratic or quasi-quadratic?
- if ValueIsUsedOrHasEffect cenv (fun () -> (freeInExpr (CollectLocalsWithStackGuard()) bodyR).FreeLocals) (bindR, bindingInfo) then
+ // Cheap occurrence check + precise fallback before eliminating
+ let v = bindR.Var
+ let usedQuick = ExprUsesLocal v bodyR
+ let usedFull =
+ if usedQuick then true
+ else
+ let fvs = freeInExpr CollectLocals bodyR
+ Zset.contains v fvs.FreeLocals
+ let keepBinding =
+ (not cenv.settings.EliminateUnusedBindings && not v.InlineIfLambda) ||
+ Option.isSome v.MemberInfo ||
+ (bindingInfo.HasEffect && not (IsDiscardableEffectExpr bindR.Expr)) ||
+ v.IsFixed ||
+ usedFull
+
+ if keepBinding then
// Eliminate let bindings on the way back up
let exprR, adjust = TryEliminateLet cenv env bindR bodyR m
exprR,
@@ -4040,8 +4110,23 @@ and OptimizeDecisionTree cenv env m x =
let (bind, binfo), envinner = OptimizeBinding cenv false env bind
let rest, rinfo = OptimizeDecisionTree cenv envinner m rest
- if ValueIsUsedOrHasEffect cenv (fun () -> (accFreeInDecisionTree CollectLocals rest emptyFreeVars).FreeLocals) (bind, binfo) then
+ // Quick occurrence check with precise fallback
+ let v = bind.Var
+ let usedQuick = DecisionTreeUsesLocal v rest
+ let usedFull =
+ if usedQuick then true
+ else
+ let fvs = accFreeInDecisionTree CollectLocals rest emptyFreeVars
+ Zset.contains v fvs.FreeLocals
+
+ let keepBinding =
+ (not cenv.settings.EliminateUnusedBindings && not v.InlineIfLambda) ||
+ Option.isSome v.MemberInfo ||
+ (binfo.HasEffect && not (IsDiscardableEffectExpr bind.Expr)) ||
+ v.IsFixed ||
+ usedFull
+ if keepBinding then
let info = CombineValueInfosUnknown [rinfo;binfo]
// try to fold the let-binding into a single result expression
match rest with
diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj
index 960057baf98..78d9fa0020d 100644
--- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj
+++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj
@@ -351,6 +351,7 @@
+
diff --git a/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs b/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs
new file mode 100644
index 00000000000..178f273d168
--- /dev/null
+++ b/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs
@@ -0,0 +1,64 @@
+namespace FSharp.Compiler.ComponentTests.Optimizer
+
+open System.Text
+open Xunit
+open FSharp.Test
+open FSharp.Test.Compiler
+open FSharp.Test.Utilities
+
+module private Gen =
+ let nestedLetApps depth =
+ // Builds: let v1 = id 0 in let v2 = id v1 in ... in ignore vN
+ let sb = StringBuilder()
+ sb.AppendLine("module M") |> ignore
+ sb.AppendLine("let id x = x") |> ignore
+ sb.AppendLine("let run () =") |> ignore
+ for i in 1 .. depth do
+ if i = 1 then
+ sb.Append(" let v1 = id 0") |> ignore
+ else
+ sb.Append(" in let v").Append(i).Append(" = id v").Append(i-1) |> ignore
+ sb.AppendLine(" in ()") |> ignore
+ sb.ToString()
+
+ let nestedDirectApps depth =
+ // Builds: let res = id(id(id(...(0)))) in ignore res
+ let sb = StringBuilder()
+ sb.AppendLine("module N") |> ignore
+ sb.AppendLine("let id x = x") |> ignore
+ sb.Append("let run () = let res = ") |> ignore
+ for _ in 1 .. depth do
+ sb.Append("id (") |> ignore
+ sb.Append("0") |> ignore
+ for _ in 1 .. depth do
+ sb.Append(")") |> ignore
+ sb.AppendLine(" in ignore res") |> ignore
+ sb.ToString()
+
+[]
+type ``Nested application optimizer``() =
+
+ // Moderate depths to keep CI stable while still exercising the quadratic shapes
+ []
+ []
+ []
+ let ``let-chains of nested apps compile under --optimize+`` depth =
+ let src = Gen.nestedLetApps depth
+ FSharp src
+ |> withOptions [ "--optimize+"; "--times" ]
+ |> asExe
+ |> ignoreWarnings
+ |> compile
+ |> shouldSucceed
+
+ []
+ []
+ []
+ let ``direct nested application compiles under --optimize+`` depth =
+ let src = Gen.nestedDirectApps depth
+ FSharp src
+ |> withOptions [ "--optimize+"; "--times" ]
+ |> asExe
+ |> ignoreWarnings
+ |> compile
+ |> shouldSucceed
\ No newline at end of file