Skip to content

Commit

Permalink
Fix16431 - Modify DU static initialization (#16661)
Browse files Browse the repository at this point in the history 
* Fix16431 - Modify DU static initialization #16661

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

Co-authored-by: Florian Verdonck <florian.verdonck@outlook.com>

---------

Co-authored-by: Florian Verdonck <florian.verdonck@outlook.com>
Co-authored-by: Petr <psfinaki@users.noreply.github.com>
  • Loading branch information
@KevinRansom @nojaf @psfinaki
3 people authored Feb 8, 2024
1 parent fa4dcfc commit ebf21ff
Show file tree
Hide file tree
Showing 5 changed files with 114 additions and 36 deletions.
1 change: 1 addition & 0 deletions docs/release-notes/.FSharp.Compiler.Service/8.0.300.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@
* 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))
* `[<CliEvent>]` member should not produce property symbol. ([Issue #16640](https://github.com/dotnet/fsharp/issues/16640), [PR #16658](https://github.com/dotnet/fsharp/pull/16658))
* Fix discriminated union initialization. ([#PR 16661](https://github.com/dotnet/fsharp/pull/16661))

### Added

Expand Down
26 changes: 26 additions & 0 deletions src/Compiler/AbstractIL/il.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
3 changes: 2 additions & 1 deletion src/Compiler/AbstractIL/il.fsi
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down
80 changes: 45 additions & 35 deletions src/Compiler/CodeGen/IlxGen.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ->
Expand All @@ -1917,6 +1926,8 @@ type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) =

gmethods.Add(mkILClassCtor body)

this

and TypeDefsBuilder() =

let tdefs =
Expand Down Expand Up @@ -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))

Expand All @@ -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 -> ()
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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) =
Expand Down
40 changes: 40 additions & 0 deletions tests/FSharp.Compiler.ComponentTests/Conformance/Types/UnionTypes/UnionTypes.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

0 comments on commit ebf21ff

Please sign in to comment.