Fix16431 - Modify DU static initialization #16661

Author: KevinRansom

docs/release-notes/.FSharp.Compiler.Service/8.0.300.md

@@ -5,7 +5,7 @@
 * Graph Based Checking doesn't throw on invalid parsed input so it can be used for IDE scenarios ([PR #16575](https://github.com/dotnet/fsharp/pull/16575), [PR #16588](https://github.com/dotnet/fsharp/pull/16588), [PR #16643](https://github.com/dotnet/fsharp/pull/16643))
 * Keep parens for problematic exprs (`if`, `match`, etc.) in `$"{(…):N0}"`, `$"{(…),-3}"`, etc. ([PR #16578](https://github.com/dotnet/fsharp/pull/16578))
 * Fix crash in DOTNET_SYSTEM_GLOBALIZATION_INVARIANT mode [#PR 16471](https://github.com/dotnet/fsharp/pull/16471))
-
+* Alter initialization code for DUs.[#PR 16661](https://github.com/dotnet/fsharp/pull/16661)
 
 ### Added
 

src/Compiler/AbstractIL/il.fs

@@ -3952,6 +3952,29 @@ let mdef_code2code f (md: ILMethodDef) =
     let b = MethodBody.IL(notlazy ilCode)
     md.With(body = notlazy b)
 
+let appendInstrsToCode (instrs: ILInstr list) (c2: ILCode) =
+    let instrs = Array.ofList instrs
+
+    match
+        c2.Instrs
+        |> Array.tryFindIndexBack (fun instr ->
+            match instr with
+            | I_ret -> true
+            | _ -> false)
+    with
+    | Some 0 ->
+        { c2 with
+            Instrs = Array.concat [| instrs; c2.Instrs |]
+        }
+    | Some index ->
+        { c2 with
+            Instrs = Array.concat [| c2.Instrs[.. index - 1]; instrs; c2.Instrs[index..] |]
+        }
+    | None ->
+        { c2 with
+            Instrs = Array.append c2.Instrs instrs
+        }
+
 let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) =
     let instrs = Array.ofList instrs
     let n = instrs.Length
@@ -3985,6 +4008,9 @@ let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) =
             Instrs = Array.append instrs c2.Instrs
         }
 
+let appendInstrsToMethod newCode md =
+    mdef_code2code (appendInstrsToCode newCode) md
+
 let prependInstrsToMethod newCode md =
     mdef_code2code (prependInstrsToCode newCode) md
 

src/Compiler/AbstractIL/il.fsi

@@ -2162,8 +2162,9 @@ val internal mkRawDataValueTypeDef: ILType -> string * size: int32 * pack: uint1
 /// the code, and the first instruction will be the new entry
 /// of the method.  The instructions should be non-branching.
 
+val internal appendInstrsToCode: ILInstr list -> ILCode -> ILCode
+val internal appendInstrsToMethod: ILInstr list -> ILMethodDef -> ILMethodDef
 val internal prependInstrsToCode: ILInstr list -> ILCode -> ILCode
-
 val internal prependInstrsToMethod: ILInstr list -> ILMethodDef -> ILMethodDef
 
 /// Injecting initialization code into a class.

src/Compiler/CodeGen/IlxGen.fs

@@ -1908,7 +1908,16 @@ type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) =
         if not discard then
             AddPropertyDefToHash m gproperties pdef
 
-    member _.PrependInstructionsToSpecificMethodDef(cond, instrs, tag, imports) =
+    member _.AppendInstructionsToSpecificMethodDef(cond, instrs, tag, imports) =
+        match ResizeArray.tryFindIndex cond gmethods with
+        | Some idx -> gmethods[idx] <- appendInstrsToMethod instrs gmethods[idx]
+        | None ->
+            let body =
+                mkMethodBody (false, [], 1, nonBranchingInstrsToCode instrs, tag, imports)
+
+            gmethods.Add(mkILClassCtor body)
+
+    member this.PrependInstructionsToSpecificMethodDef(cond, instrs, tag, imports) =
         match ResizeArray.tryFindIndex cond gmethods with
         | Some idx -> gmethods[idx] <- prependInstrsToMethod instrs gmethods[idx]
         | None ->
@@ -1917,6 +1926,8 @@ type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) =
 
             gmethods.Add(mkILClassCtor body)
 
+        this
+
 and TypeDefsBuilder() =
 
     let tdefs =
@@ -2264,6 +2275,22 @@ and AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf
     /// static init fields on script modules.
     let scriptInitFspecs = ConcurrentStack<ILFieldSpec * range>()
 
+    let initialInstrs seqpt feefee =
+        [
+            yield!
+                (if isEnvVarSet "NO_ADD_FEEFEE_TO_CCTORS" then []
+                 elif isEnvVarSet "ADD_SEQPT_TO_CCTORS" then seqpt
+                 else feefee) // mark start of hidden code
+        ]
+
+    let finalInstrs fspec =
+        [
+            yield mkLdcInt32 0
+            yield mkNormalStsfld fspec
+            yield mkNormalLdsfld fspec
+            yield AI_pop
+        ]
+
     member _.AddScriptInitFieldSpec(fieldSpec, range) =
         scriptInitFspecs.Push((fieldSpec, range))
 
@@ -2276,15 +2303,7 @@ and AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf
             let InitializeCompiledScript (fspec, m) =
                 let ilDebugRange = GenPossibleILDebugRange cenv m
 
-                mgbuf.AddExplicitInitToSpecificMethodDef(
-                    (fun (md: ILMethodDef) -> md.IsEntryPoint),
-                    tref,
-                    fspec,
-                    ilDebugRange,
-                    imports,
-                    [],
-                    []
-                )
+                mgbuf.AddExplicitInitToEntryPoint(tref, fspec, ilDebugRange, imports, [], [])
 
             scriptInitFspecs |> Seq.iter InitializeCompiledScript
         | None -> ()
@@ -2325,24 +2344,23 @@ and AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf
         if ilMethodDef.IsEntryPoint then
             explicitEntryPointInfo <- Some tref
 
-    member _.AddExplicitInitToSpecificMethodDef(cond, tref, fspec, sourceOpt, imports, feefee, seqpt) =
-        // Authoring a .cctor with effects forces the cctor for the 'initialization' module by doing a dummy store & load of a field
-        // Doing both a store and load keeps FxCop happier because it thinks the field is useful
-        let instrs =
-            [
-                yield!
-                    (if isEnvVarSet "NO_ADD_FEEFEE_TO_CCTORS" then []
-                     elif isEnvVarSet "ADD_SEQPT_TO_CCTORS" then seqpt
-                     else feefee) // mark start of hidden code
-                yield mkLdcInt32 0
-                yield mkNormalStsfld fspec
-                yield mkNormalLdsfld fspec
-                yield AI_pop
-            ]
+    member _.AddExplicitInitToEntryPoint(tref, fspec, sourceOpt, imports, feefee, seqpt) =
+
+        let cond = (fun (md: ILMethodDef) -> md.IsEntryPoint)
 
         gtdefs
             .FindNestedTypeDefBuilder(tref)
-            .PrependInstructionsToSpecificMethodDef(cond, instrs, sourceOpt, imports)
+            .PrependInstructionsToSpecificMethodDef(cond, (initialInstrs seqpt feefee) @ (finalInstrs fspec), sourceOpt, imports)
+        |> ignore
+
+    member _.AddExplicitInitToCctor(tref, fspec, sourceOpt, imports, feefee, seqpt) =
+
+        let cond = (fun (md: ILMethodDef) -> md.Name = ".cctor")
+
+        gtdefs
+            .FindNestedTypeDefBuilder(tref)
+            .PrependInstructionsToSpecificMethodDef(cond, initialInstrs seqpt feefee, sourceOpt, imports)
+            .AppendInstructionsToSpecificMethodDef(cond, finalInstrs fspec, sourceOpt, imports)
 
     member _.AddEventDef(tref, edef) =
         gtdefs.FindNestedTypeDefBuilder(tref).AddEventDef(edef)
@@ -10194,15 +10212,7 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: Checke
                     // This adds the explicit init of the .cctor to the explicit entry point main method
                     let ilDebugRange = GenPossibleILDebugRange cenv m
 
-                    mgbuf.AddExplicitInitToSpecificMethodDef(
-                        (fun md -> md.IsEntryPoint),
-                        tref,
-                        fspec,
-                        ilDebugRange,
-                        eenv.imports,
-                        feefee,
-                        seqpt
-                    ))
+                    mgbuf.AddExplicitInitToEntryPoint(tref, fspec, ilDebugRange, eenv.imports, feefee, seqpt))
 
                 let cctorMethDef =
                     mkILClassCtor (MethodBody.IL(InterruptibleLazy.FromValue topCode))
@@ -10289,7 +10299,7 @@ and GenForceWholeFileInitializationAsPartOfCCtor cenv (mgbuf: AssemblyBuilder) (
     // Doing both a store and load keeps FxCop happier because it thinks the field is useful
     lazyInitInfo.Add(fun fspec feefee seqpt ->
         let ilDebugRange = GenPossibleILDebugRange cenv m
-        mgbuf.AddExplicitInitToSpecificMethodDef((fun md -> md.Name = ".cctor"), tref, fspec, ilDebugRange, imports, feefee, seqpt))
+        mgbuf.AddExplicitInitToCctor(tref, fspec, ilDebugRange, imports, feefee, seqpt))
 
 /// Generate an Equals method.
 and GenEqualsOverrideCallingIComparable cenv (tcref: TyconRef, ilThisTy, _ilThatTy) =

tests/FSharp.Compiler.ComponentTests/Conformance/Types/UnionTypes/UnionTypes.fs

@@ -609,3 +609,43 @@ module UnionTypes =
         |> withDiagnostics [
             (Warning 42, Line 11, Col 12, Line 11, Col 24, "This construct is deprecated: it is only for use in the F# library")
         ]
+
+
+    //SOURCE=W_UnionCaseProduction01.fsx SCFLAGS="-a --test:ErrorRanges"                          # W_UnionCaseProduction01.fsx
+    [<Fact>]
+    let ``UnionCaseInitialization_repro16431`` () =
+
+        let testFs =
+            SourceCodeFileKind.Create(
+                "testFs.fs",
+                $"""
+module Test
+
+type ABC =
+    | A
+    | B
+    | C of int
+
+    static let c75' = ABC.C 75
+    static member c75 = c75'
+
+    static let ab' = [ A; B ]
+    static member ab = ab'
+                 """)
+
+        let programFs =
+            SourceCodeFileKind.Create(
+                "programFs.fs",
+                $"""
+open Test
+
+if (sprintf "%%A" ABC.c75) <> "C 75" then failwith (sprintf "Failed: printing 'ABC.c75': Expected output: 'C 75'  Actual output: '%%A'" ABC.c75)
+if (sprintf "%%A" ABC.ab) <> "[A; B]" then failwith (sprintf "Failed: printing 'ABC.ab: Expected: '[A; B]'  Actual: '%%A'" ABC.ab)
+                 """)
+
+        (fsFromString testFs)
+        |> FS
+        |> withAdditionalSourceFiles [programFs]
+        |> asExe
+        |> compileAndRun
+        |> shouldSucceed