Permit reduction of Some allocations for optional arguments (#6533)

* Optimization of inlined code doesn't always reduce `Some` allocations for optional arguments

* add codegen test

* add baseline

* Update OptionalArg01.fs

Author: dsyme

src/fsharp/Optimizer.fs

@@ -354,7 +354,8 @@ type OptimizationSettings =
     /// eliminate non-compiler generated immediate bindings 
     member x.EliminateImmediatelyConsumedLocals() = x.localOpt () 
 
-    /// expand "let x = (exp1, exp2, ...)" bind fields as prior tmps 
+    /// expand "let x = (exp1, exp2, ...)" bindings as prior tmps 
+    /// expand "let x = Some exp1" bindings as prior tmps 
     member x.ExpandStructrualValues() = x.localOpt () 
 
 type cenv =
@@ -1552,6 +1553,8 @@ let rec CombineBoolLogic expr =
 // Similarly for other structural constructions, like records...
 // If the item is only projected from then the construction (allocation) can be eliminated.
 // This transform encourages that by allowing projections to be simplified.
+//
+// Apply the same to 'Some(x)' constructions
 //------------------------------------------------------------------------- 
 
 let CanExpandStructuralBinding (v: Val) =
@@ -1562,7 +1565,13 @@ let CanExpandStructuralBinding (v: Val) =
 
 let ExprIsValue = function Expr.Val _ -> true | _ -> false
 
+let MakeStructuralBindingTemp (v: Val) i (arg: Expr) argTy =
+    let name = v.LogicalName + "_" + string i
+    let v, ve = mkCompGenLocal arg.Range name argTy
+    ve, mkCompGenBind v arg
+           
 let ExpandStructuralBindingRaw cenv expr =
+    assert cenv.settings.ExpandStructrualValues()
     match expr with
     | Expr.Let (TBind(v, rhs, tgtSeqPtOpt), body, m, _) 
         when (isRefTupleExpr rhs &&
@@ -1572,19 +1581,16 @@ let ExpandStructuralBindingRaw cenv expr =
               expr (* avoid re-expanding when recursion hits original binding *)
           else
               let argTys = destRefTupleTy cenv.g v.Type
-              let argBind i (arg: Expr) argTy =
-                  let name = v.LogicalName + "_" + string i
-                  let v, ve = mkCompGenLocal arg.Range name argTy
-                  ve, mkCompGenBind v arg
-           
-              let ves, binds = List.mapi2 argBind args argTys |> List.unzip
+              let ves, binds = List.mapi2 (MakeStructuralBindingTemp v) args argTys |> List.unzip
               let tuple = mkRefTupled cenv.g m ves argTys
               mkLetsBind m binds (mkLet tgtSeqPtOpt m v tuple body)
     | expr -> expr
 
 // Moves outer tuple binding inside near the tupled expression:
-// let t = (let a0=v0 in let a1=v1 in ... in let an=vn in e0, e1, ..., em) in body
-// let a0=v0 in let a1=v1 in ... in let an=vn in (let t = e0, e1, ..., em in body)
+//   let t = (let a0=v0 in let a1=v1 in ... in let an=vn in e0, e1, ..., em) in body
+// becomes
+//   let a0=v0 in let a1=v1 in ... in let an=vn in (let t = e0, e1, ..., em in body)
+//
 // This way ExpandStructuralBinding can replace expressions in constants, t is directly bound
 // to a tuple expression so that other optimizations such as OptimizeTupleFieldGet work, 
 // and the tuple allocation can be eliminated.
@@ -1600,6 +1606,7 @@ let rec RearrangeTupleBindings expr fin =
     | _ -> None
 
 let ExpandStructuralBinding cenv expr =
+    assert cenv.settings.ExpandStructrualValues()
     match expr with
     | Expr.Let (TBind(v, rhs, tgtSeqPtOpt), body, m, _)
         when (isRefTupleTy cenv.g v.Type &&
@@ -1608,7 +1615,20 @@ let ExpandStructuralBinding cenv expr =
         match RearrangeTupleBindings rhs (fun top -> mkLet tgtSeqPtOpt m v top body) with
         | Some e -> ExpandStructuralBindingRaw cenv e
         | None -> expr
-    | e -> ExpandStructuralBindingRaw cenv e
+
+    // Expand 'let v = Some arg in ...' to 'let tmp = arg in let v = Some tp in ...'
+    // Used to give names to values of optional arguments prior as we inline.
+    | Expr.Let (TBind(v, Expr.Op(TOp.UnionCase uc, _, [arg], _), tgtSeqPtOpt), body, m, _)
+        when isOptionTy cenv.g v.Type && 
+             not (ExprIsValue arg) && 
+             cenv.g.unionCaseRefEq uc (mkSomeCase cenv.g) &&
+             CanExpandStructuralBinding v ->
+            let argTy = destOptionTy cenv.g v.Type 
+            let ve, bind = MakeStructuralBindingTemp v 0 arg argTy
+            let newExpr = mkSome cenv.g argTy ve m
+            mkLetBind m bind (mkLet tgtSeqPtOpt m v newExpr body)
+    | e ->
+        ExpandStructuralBindingRaw cenv e
 
 /// Detect a query { ... }
 let (|QueryRun|_|) g expr = 

src/fsharp/TastOps.fs

@@ -3143,6 +3143,10 @@ let destLinqExpressionTy g ty =
 let mkNoneCase (g: TcGlobals) = mkUnionCaseRef g.option_tcr_canon "None"
 let mkSomeCase (g: TcGlobals) = mkUnionCaseRef g.option_tcr_canon "Some"
 
+let mkSome g ty arg m = mkUnionCaseExpr(mkSomeCase g, [ty], [arg], m)
+
+let mkNone g ty m = mkUnionCaseExpr(mkNoneCase g, [ty], [], m)
+
 type ValRef with 
     member vref.IsDispatchSlot = 
         match vref.MemberInfo with 

src/fsharp/TastOps.fsi

@@ -1648,6 +1648,10 @@ val mkNil  : TcGlobals -> range -> TType -> Expr
 
 val mkCons : TcGlobals -> TType -> Expr -> Expr -> Expr
 
+val mkSome : TcGlobals -> TType -> Expr -> range -> Expr
+
+val mkNone: TcGlobals -> TType -> range -> Expr
+
 //-------------------------------------------------------------------------
 // Make a few more expressions
 //------------------------------------------------------------------------- 

src/fsharp/TypeChecker.fs

@@ -10164,16 +10164,16 @@ and TcMethodApplication
 
                       match calledArg.CallerInfo, env.eCallerMemberName with
                       | CallerLineNumber, _ when typeEquiv cenv.g calledNonOptTy cenv.g.int_ty ->
-                          let lineExpr = Expr.Const (Const.Int32(mMethExpr.StartLine), mMethExpr, calledNonOptTy)
-                          emptyPreBinder, mkUnionCaseExpr(mkSomeCase cenv.g, [calledNonOptTy], [lineExpr], mMethExpr)
+                          let lineExpr = Expr.Const(Const.Int32 mMethExpr.StartLine, mMethExpr, calledNonOptTy)
+                          emptyPreBinder, mkSome cenv.g calledNonOptTy lineExpr mMethExpr
                       | CallerFilePath, _ when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty ->
-                          let filePathExpr = Expr.Const (Const.String(FileSystem.GetFullPathShim(mMethExpr.FileName)), mMethExpr, calledNonOptTy)
-                          emptyPreBinder, mkUnionCaseExpr(mkSomeCase cenv.g, [calledNonOptTy], [filePathExpr], mMethExpr)
-                      | CallerMemberName, Some callerName when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty ->
+                          let filePathExpr = Expr.Const (Const.String (FileSystem.GetFullPathShim(mMethExpr.FileName)), mMethExpr, calledNonOptTy)
+                          emptyPreBinder, mkSome cenv.g calledNonOptTy filePathExpr mMethExpr
+                      | CallerMemberName, Some(callerName) when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty ->
                           let memberNameExpr = Expr.Const (Const.String callerName, mMethExpr, calledNonOptTy)
-                          emptyPreBinder, mkUnionCaseExpr(mkSomeCase cenv.g, [calledNonOptTy], [memberNameExpr], mMethExpr)
+                          emptyPreBinder, mkSome cenv.g calledNonOptTy memberNameExpr mMethExpr
                       | _ ->
-                          emptyPreBinder, mkUnionCaseExpr(mkNoneCase cenv.g, [calledNonOptTy], [], mMethExpr)
+                          emptyPreBinder, mkNone cenv.g calledNonOptTy mMethExpr
 
               // Combine the variable allocators (if any)
               let wrapper = (wrapper >> wrapper2)
@@ -10207,7 +10207,7 @@ and TcMethodApplication
                             let calledArgTy = assignedArg.CalledArg.CalledArgumentType
                             if isOptionTy cenv.g calledArgTy then 
                                 let calledNonOptTy = destOptionTy cenv.g calledArgTy 
-                                mkUnionCaseExpr(mkSomeCase cenv.g, [calledNonOptTy], [mkCoerceIfNeeded cenv.g calledNonOptTy callerArgTy expr], m)
+                                mkSome cenv.g calledNonOptTy (mkCoerceIfNeeded cenv.g calledNonOptTy callerArgTy expr) m
                             else 
                                 expr // should be unreachable 
 

tests/fsharpqa/Source/CodeGen/EmittedIL/Tuples/OptionalArg01.fs

@@ -0,0 +1,46 @@
+// #NoMono #NoMT #CodeGen #EmittedIL #Tuples   
+type A() = class end
+
+// A code+optimization pattern, see https://github.com/Microsoft/visualfsharp/issues/6532
+type C() = 
+    static member inline F (?x1: A, ?x2: A) = 
+        let count = 0
+        let count = match x1 with None -> count | Some _ -> count + 1
+        let count = match x2 with None -> count | Some _ -> count + 1
+        let attribs = ResizeArray<_>(count)
+        match x1 with None -> () | Some v1 -> attribs.Add(v1)
+        match x2 with None -> () | Some v2 -> attribs.Add(v2)
+        attribs
+
+//Expect rough equivalent of:
+//        let d = ResizeArray<_>(0)
+//        d
+let test() = 
+    C.F ()
+
+//Expect rough equivalent of:
+//        let x1 = A()
+//        let d = ResizeArray<_>(1)
+//        d.Add(x1)
+//        d
+let test2() = 
+    C.F (x1=A())
+
+//Expect rough equivalent of:
+//        let x2 = A()
+//        let d = ResizeArray<_>(1)
+//        d.Add(x2)
+//        d
+let test3() = 
+    C.F (x2=A())
+
+//Expect rough equivalent of:
+//        let x1 = A()
+//        let x2 = A()
+//        let d = ResizeArray<_>(2)
+//        d.Add(x1)
+//        d.Add(x2)
+//        d
+let test4() = 
+    C.F (x1=A(), x2=A())
+