From 2db5e171a2c0686d45d6ca33f132fb9653d347fd Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Tue, 9 Sep 2025 18:39:09 +0200
Subject: [PATCH 1/3] quick "occurs" check
---
src/Compiler/Optimize/Optimizer.fs | 111 ++++++++++++++++++++++++-----
1 file changed, 95 insertions(+), 16 deletions(-)
diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs
index 52e404cea3e..f41dd25ad14 100644
--- a/src/Compiler/Optimize/Optimizer.fs
+++ b/src/Compiler/Optimize/Optimizer.fs
@@ -9,7 +9,6 @@ open Internal.Utilities.Collections
open Internal.Utilities.Library
open Internal.Utilities.Library.Extras
open FSharp.Compiler
-open FSharp.Compiler.AbstractIL.Diagnostics
open FSharp.Compiler.AbstractIL.IL
open FSharp.Compiler.AttributeChecking
open FSharp.Compiler.CompilerGlobalState
@@ -17,16 +16,11 @@ open FSharp.Compiler.DiagnosticsLogger
open FSharp.Compiler.Text.Range
open FSharp.Compiler.Syntax.PrettyNaming
open FSharp.Compiler.Syntax
-open FSharp.Compiler.SyntaxTreeOps
open FSharp.Compiler.TcGlobals
open FSharp.Compiler.Text
-open FSharp.Compiler.Text.Layout
-open FSharp.Compiler.Text.LayoutRender
-open FSharp.Compiler.Text.TaggedText
open FSharp.Compiler.TypedTree
open FSharp.Compiler.TypedTreeBasics
open FSharp.Compiler.TypedTreeOps
-open FSharp.Compiler.TypedTreeOps.DebugPrint
open FSharp.Compiler.TypedTreePickle
open FSharp.Compiler.TypeHierarchy
open FSharp.Compiler.TypeRelations
@@ -36,6 +30,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 +1755,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 +1789,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 +2947,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 +4104,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
From 9fb878b7a8dec133c26d713fd1b4b91ea62213fe Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Tue, 9 Sep 2025 19:52:39 +0200
Subject: [PATCH 2/3] add a test
---
.../FSharp.Compiler.ComponentTests.fsproj | 1 +
.../Optimizer/NestedApplications.fs | 64 +++++++++++++++++++
2 files changed, 65 insertions(+)
create mode 100644 tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs
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
From 0c7ca457b76f3ff8d10a7764d12e9f77f0fb987a Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Tue, 9 Sep 2025 20:21:51 +0200
Subject: [PATCH 3/3] fix debug
---
src/Compiler/Optimize/Optimizer.fs | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs
index f41dd25ad14..2fcab81b195 100644
--- a/src/Compiler/Optimize/Optimizer.fs
+++ b/src/Compiler/Optimize/Optimizer.fs
@@ -9,6 +9,7 @@ open Internal.Utilities.Collections
open Internal.Utilities.Library
open Internal.Utilities.Library.Extras
open FSharp.Compiler
+open FSharp.Compiler.AbstractIL.Diagnostics
open FSharp.Compiler.AbstractIL.IL
open FSharp.Compiler.AttributeChecking
open FSharp.Compiler.CompilerGlobalState
@@ -16,11 +17,16 @@ open FSharp.Compiler.DiagnosticsLogger
open FSharp.Compiler.Text.Range
open FSharp.Compiler.Syntax.PrettyNaming
open FSharp.Compiler.Syntax
+open FSharp.Compiler.SyntaxTreeOps
open FSharp.Compiler.TcGlobals
open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
open FSharp.Compiler.TypedTree
open FSharp.Compiler.TypedTreeBasics
open FSharp.Compiler.TypedTreeOps
+open FSharp.Compiler.TypedTreeOps.DebugPrint
open FSharp.Compiler.TypedTreePickle
open FSharp.Compiler.TypeHierarchy
open FSharp.Compiler.TypeRelations