Optimizer: propagate NoDynamicInvocation

src/Compiler/Optimize/Optimizer.fs

@@ -437,6 +437,9 @@ type cenv =
 
       specializedInlineVals: HashMultiMap<Stamp, TType * Expr>
 
+      /// Cache for 'HasFrameLocalBody'
+      frameLocalVals: Dictionary<Stamp, bool>
+
       signatureHidingInfo: SignatureHidingInfo
     }
 
@@ -622,20 +625,23 @@ let BindTyparsToUnknown (tps: Typar list) env =
 let BindCcu (ccu: CcuThunk) mval env (_g: TcGlobals) = 
     { env with globalModuleInfos=env.globalModuleInfos.Add(ccu.AssemblyName, mval) }
 
-/// Lookup information about values 
-let GetInfoForLocalValue cenv env (v: Val) m = 
-    // Abstract slots do not have values 
-    if v.IsDispatchSlot then UnknownValInfo 
+/// Lookup information about values, without reporting values that are not bound yet
+let TryGetInfoForLocalValue cenv env (v: Val) =
+    // Abstract slots do not have values
+    if v.IsDispatchSlot then None
     else
         match cenv.localInternalVals.TryGetValue v.Stamp with
-        | true, res -> res
-        | _ ->
-            match env.localExternalVals.TryFind v.Stamp with 
-            | Some vval -> vval
-            | None -> 
-                if v.ShouldInline then
-                    errorR(Error(FSComp.SR.optValueMarkedInlineButWasNotBoundInTheOptEnv(fullDisplayTextOfValRef (mkLocalValRef v)), m))
-                UnknownValInfo 
+        | true, res -> Some res
+        | _ -> env.localExternalVals.TryFind v.Stamp
+
+/// Lookup information about values
+let GetInfoForLocalValue cenv env (v: Val) m =
+    match TryGetInfoForLocalValue cenv env v with
+    | Some vval -> vval
+    | None ->
+        if not v.IsDispatchSlot && v.ShouldInline then
+            errorR(Error(FSComp.SR.optValueMarkedInlineButWasNotBoundInTheOptEnv(fullDisplayTextOfValRef (mkLocalValRef v)), m))
+        UnknownValInfo
 
 let TryGetInfoForCcu env (ccu: CcuThunk) = env.globalModuleInfos.TryFind(ccu.AssemblyName)
 
@@ -682,14 +688,20 @@ let GetInfoForNonLocalVal cenv env (vref: ValRef) =
     else 
         UnknownValInfo
 
-let GetInfoForVal cenv env m (vref: ValRef) =  
-    let res = 
+let GetInfoForVal cenv env m (vref: ValRef) =
+    let res =
         if vref.IsLocalRef then
             GetInfoForLocalValue cenv env vref.binding m
         else
             GetInfoForNonLocalVal cenv env vref
     res
 
+let TryGetInfoForVal cenv env (vref: ValRef) =
+    if vref.IsLocalRef then
+        TryGetInfoForLocalValue cenv env vref.binding
+    else
+        Some(GetInfoForNonLocalVal cenv env vref)
+
 
 let IsPartialExpr cenv env m x =
     let rec isPartialExpression x =
@@ -2426,11 +2438,57 @@ let shouldForceInlineMembersInDebug (g: TcGlobals) (tcref: EntityRef) =
     | true, modRef -> tyconRefEq g tcref modRef 
     | _ -> false
 
-let shouldForceInlineInDebug (g: TcGlobals) (vref: ValRef) : bool =
+/// 'localloc' storage is released when the method executing it returns, so anything derived from
+/// it dangles at that method's callsite.
+let instrIsFrameLocal instr =
+    match instr with
+    | I_localloc -> true
+    | _ -> false
+
+/// The FSharp.Core values expanding to frame-local IL are marked [<NoDynamicInvocation>] and so are
+/// always inlined. A user 'inline' function wrapping one inherits the property but not the
+/// attribute - the callee is already inlined into the recorded body, leaving only its IL - so
+/// recover it from the body and propagate it through further wrappers.
+/// See https://github.com/dotnet/fsharp/issues/20063.
+let rec HasFrameLocalBody cenv env (vref: ValRef) =
+    let stamp = vref.Stamp
+
+    match cenv.frameLocalVals.TryGetValue stamp with
+    | true, res -> res
+    | _ ->
+        // Values bound within the body being walked have no info yet, but the walk covers them anyway.
+        match TryGetInfoForVal cenv env vref |> Option.map (fun info -> stripValue info.ValExprInfo) with
+        | Some(CurriedLambdaValue (_, _, _, body, _)) ->
+            cenv.frameLocalVals[stamp] <- false // Break cycles while the body is inspected
+            let res = ExprIsFrameLocal cenv env body
+            cenv.frameLocalVals[stamp] <- res
+            res
+
+        | _ -> false
+
+and ExprIsFrameLocal cenv env expr =
+    let folder =
+        { ExprFolder0 with
+            exprIntercept =
+                fun _recurseF noInterceptF acc expr ->
+                    if acc then acc else
+
+                    match expr with
+                    | Expr.Op (TOp.ILAsm (instrs, _), _, _, _) when List.exists instrIsFrameLocal instrs -> true
+                    | Expr.Val (vref, _, _) when vref.ShouldInline -> HasFrameLocalBody cenv env vref
+                    | _ -> noInterceptF acc expr }
+
+    FoldExpr folder false expr
+
+let shouldForceInlineInDebug cenv env (vref: ValRef) : bool =
+    let g = cenv.g
+
     ValHasWellKnownAttribute g WellKnownValAttributes.NoDynamicInvocationAttribute_True vref.Deref ||
     ValHasWellKnownAttribute g WellKnownValAttributes.NoDynamicInvocationAttribute_False vref.Deref ||
 
-    vref.HasDeclaringEntity && shouldForceInlineMembersInDebug g vref.DeclaringEntity
+    (vref.HasDeclaringEntity && shouldForceInlineMembersInDebug g vref.DeclaringEntity) ||
+
+    HasFrameLocalBody cenv env vref
 
 /// Optimize/analyze an expression
 let rec OptimizeExpr cenv (env: IncrementalOptimizationEnv) expr =
@@ -3179,7 +3237,7 @@ and TryOptimizeVal cenv env (vOpt: ValRef option, shouldInline, inlineIfLambda,
         Some (remarkExpr m (copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated expr))
 
     | CurriedLambdaValue (_, _, _, expr, _) when
-            shouldInline && (cenv.settings.alwaysInline || Option.exists (shouldForceInlineInDebug cenv.g) vOpt) ||
+            shouldInline && (cenv.settings.alwaysInline || Option.exists (shouldForceInlineInDebug cenv env) vOpt) ||
             inlineIfLambda && cenv.settings.alwaysInline ->
         let fvs = freeInExpr CollectLocals expr
         if usesMethodLocalConstructsOrProtectedField cenv fvs expr then
@@ -3534,7 +3592,7 @@ and TryInlineApplication cenv env finfo (valExpr: Expr) (tyargs: TType list, arg
     let g = cenv.g
 
     match cenv.settings.alwaysInline, stripExpr valExpr with
-    | false, Expr.Val(vref, _, _) when vref.ShouldInline && not (shouldForceInlineInDebug cenv.g vref) ->
+    | false, Expr.Val(vref, _, _) when vref.ShouldInline && not (shouldForceInlineInDebug cenv env vref) ->
         let hasNoTraits =
             let tps, _ = tryDestForallTy g vref.Type
             GetTraitConstraintInfosOfTypars g tps |> List.isEmpty
@@ -4677,6 +4735,7 @@ let OptimizeImplFile (settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncr
           stackGuard = StackGuard("OptimizerStackGuardDepth")
           realsig = tcGlobals.realsig
           specializedInlineVals = HashMultiMap(HashIdentity.Structural, true)
+          frameLocalVals = Dictionary<Stamp, bool>()
           signatureHidingInfo = SignatureHidingInfo.Empty
         }
 

tests/FSharp.Compiler.ComponentTests/EmittedIL/DebugInlineAsCall.fs

@@ -2,6 +2,7 @@ namespace EmittedIL
 
 open System.Diagnostics
 open System.Runtime.CompilerServices
+open FSharp.Test
 open Xunit
 open FSharp.Test.Compiler
 
@@ -1595,3 +1596,108 @@ let main _ =
         |> shouldSucceed
         |> verifyILNotPresent ["call       int32 Test::apply(class [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2<int32,int32>,"]
 
+    // https://github.com/dotnet/fsharp/issues/20063
+    [<FactForNETCOREAPP>]
+    let ``Stackalloc 01 - Debug`` () =
+        FSharp """
+open System
+open FSharp.NativeInterop
+#nowarn 9
+
+let inline stackalloc n = Span<char>(NativePtr.stackalloc<char> n |> NativePtr.toVoidPtr, n)
+
+[<EntryPoint>]
+let main _ =
+    let b = stackalloc 3
+    b[0] <- 'a'
+    b[1] <- 'b'
+    b[2] <- 'c'
+    if String b = "abc" then 0 else 1
+"""
+        |> withDebug
+        |> withNoOptimize
+        |> asExe
+        |> compileAndRun
+        |> verifySequencePoints
+
+    [<FactForNETCOREAPP>]
+    let ``Stackalloc 02 - Nested wrappers`` () =
+        FSharp """
+open System
+open FSharp.NativeInterop
+#nowarn 9
+
+let inline alloc n : nativeptr<char> = NativePtr.stackalloc<char> n
+let inline stackalloc n = Span<char>(alloc n |> NativePtr.toVoidPtr, n)
+
+[<EntryPoint>]
+let main _ =
+    let b = stackalloc 2
+    b[0] <- 'a'
+    b[1] <- 'b'
+    if String b = "ab" then 0 else 1
+"""
+        |> withDebug
+        |> withNoOptimize
+        |> asExe
+        |> compileAndRun
+        |> verifySequencePoints
+
+    [<FactForNETCOREAPP>]
+    let ``Stackalloc 03 - Different assembly`` () =
+        let library =
+            FSharp """
+module MyLib
+
+open System
+open FSharp.NativeInterop
+#nowarn 9
+
+let inline alloc n : nativeptr<char> = NativePtr.stackalloc<char> n
+let inline stackalloc n = Span<char>(alloc n |> NativePtr.toVoidPtr, n)
+"""
+            |> withDebug
+            |> withNoOptimize
+            |> asLibrary
+            |> withName "Lib"
+
+        FSharp """
+open System
+open MyLib
+
+[<EntryPoint>]
+let main _ =
+    let b = stackalloc 2
+    b[0] <- 'a'
+    b[1] <- 'b'
+    if String b = "ab" then 0 else 1
+"""
+        |> withDebug
+        |> withNoOptimize
+        |> withReferences [library]
+        |> asExe
+        |> compileAndRun
+        |> verifySequencePoints
+
+    [<FactForNETCOREAPP>]
+    let ``Stackalloc 04 - Only the wrappers are force inlined`` () =
+        FSharp """
+open System
+open FSharp.NativeInterop
+#nowarn 9
+
+let inline stackalloc n = Span<char>(NativePtr.stackalloc<char> n |> NativePtr.toVoidPtr, n)
+let inline fill (b: Span<char>) c = b.Fill c
+
+[<EntryPoint>]
+let main _ =
+    let b = stackalloc 2
+    fill b 'a'
+    if String b = "aa" then 0 else 1
+"""
+        |> withDebug
+        |> withNoOptimize
+        |> asExe
+        |> compileAndRun
+        |> verifySequencePoints
+

tests/FSharp.Compiler.ComponentTests/EmittedIL/DebugInlineAsCall/Stackalloc 01 - Debug.bsl

@@ -0,0 +1,92 @@
+open System
+open FSharp.NativeInterop
+#nowarn 9
+
+let inline stackalloc n = Span<char>(NativePtr.stackalloc<char> n |> NativePtr.toVoidPtr, n)
+
+[<EntryPoint>]
+let main _ =
+    let b = stackalloc 3
+    b[0] <- 'a'
+    b[1] <- 'b'
+    b[2] <- 'c'
+    if String b = "abc" then 0 else 1
+--------------------------------------------------------------------------------
+
+Test::stackalloc
+  (6,27-6,93)  Span<char>(NativePtr.stackalloc<char> n |> NativePtr.toVoidPtr, n)
+    IL_0000:  nop
+
+  (6,38-6,66)  NativePtr.stackalloc<char> n
+    IL_0001:  ldarg.0
+    IL_0002:  stloc.1
+    IL_0003:  ldloc.1
+    IL_0004:  sizeof Char
+    IL_000a:  mul
+    IL_000b:  localloc
+    IL_000d:  stloc.0
+
+  (6,70-6,89)  NativePtr.toVoidPtr
+    IL_000e:  ldloc.0
+    IL_000f:  stloc.2
+    IL_0010:  ldloc.2
+    IL_0011:  ldarg.0
+    IL_0012:  newobj .ctor
+    IL_0017:  ret
+
+Test::main
+  (10,5-10,25)  let b = stackalloc 3
+    IL_0000:  ldc.i4.3
+    IL_0001:  stloc.1
+    IL_0002:  ldloc.1
+    IL_0003:  stloc.2
+    IL_0004:  ldloc.2
+    IL_0005:  sizeof Char
+    IL_000b:  mul
+    IL_000c:  localloc
+    IL_000e:  ldloc.1
+    IL_000f:  newobj .ctor
+    IL_0014:  stloc.0
+
+  (11,5-11,9)  b[0]
+    IL_0015:  ldloca.s 0
+    IL_0017:  ldc.i4.0
+    IL_0018:  call get_Item
+    IL_001d:  stloc.3
+    IL_001e:  ldloc.3
+    IL_001f:  ldc.i4.s 97
+    IL_0021:  stobj Char
+
+  (12,5-12,9)  b[1]
+    IL_0026:  ldloca.s 0
+    IL_0028:  ldc.i4.1
+    IL_0029:  call get_Item
+    IL_002e:  stloc.s 4
+    IL_0030:  ldloc.s 4
+    IL_0032:  ldc.i4.s 98
+    IL_0034:  stobj Char
+
+  (13,5-13,9)  b[2]
+    IL_0039:  ldloca.s 0
+    IL_003b:  ldc.i4.2
+    IL_003c:  call get_Item
+    IL_0041:  stloc.s 5
+    IL_0043:  ldloc.s 5
+    IL_0045:  ldc.i4.s 99
+    IL_0047:  stobj Char
+
+  (14,5-14,29)  if String b = "abc" then
+    IL_004c:  ldloc.0
+    IL_004d:  call op_Implicit
+    IL_0052:  newobj String::.ctor
+    IL_0057:  ldstr "abc"
+    IL_005c:  call String::Equals
+    IL_0061:  brfalse.s IL_0065
+
+  (14,30-14,31)  0
+    IL_0063:  ldc.i4.0
+    IL_0064:  ret
+
+  (14,37-14,38)  1
+    IL_0065:  ldc.i4.1
+    IL_0066:  ret