From ba3fee7652c02512872e6e80f4d7c6b6767b15f8 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Jun 2016 20:28:25 +0100 Subject: [PATCH 01/12] struct unions --- VisualFSharp.sln | 86 +---- src/absil/il.fs | 2 + src/absil/il.fsi | 2 + src/absil/ilprint.fs | 4 +- src/absil/ilwrite.fs | 2 +- src/absil/ilx.fs | 13 +- src/absil/ilx.fsi | 3 +- src/fsharp/AugmentWithHashCompare.fs | 294 ++++++++++-------- src/fsharp/ConstraintSolver.fs | 14 +- src/fsharp/FSComp.txt | 3 +- .../FSharp.Core/DiscrimantedUnionType.fs | 134 +++++++- src/fsharp/IlxGen.fs | 52 +++- src/fsharp/NameResolution.fs | 2 +- src/fsharp/Optimizer.fs | 4 +- src/fsharp/PatternMatchCompilation.fs | 39 ++- src/fsharp/PostInferenceChecks.fs | 25 +- src/fsharp/QuotationTranslator.fs | 3 + src/fsharp/TastOps.fs | 127 +++++--- src/fsharp/TastOps.fsi | 33 +- src/fsharp/TastPickle.fs | 4 + src/fsharp/TypeChecker.fs | 98 +++--- src/fsharp/infos.fs | 2 +- src/fsharp/tast.fs | 37 ++- src/ilx/EraseUnions.fs | 200 ++++++------ src/ilx/EraseUnions.fsi | 21 +- tests/fsharp/typecheck/sigs/neg95.bsl | 6 +- tests/fsharp/typecheck/sigs/neg95.fs | 6 + 27 files changed, 753 insertions(+), 463 deletions(-) diff --git a/VisualFSharp.sln b/VisualFSharp.sln index 6224d843be15..002dbd63f6ba 100644 --- a/VisualFSharp.sln +++ b/VisualFSharp.sln @@ -1,7 +1,7 @@  Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 14 -VisualStudioVersion = 14.0.25123.0 +VisualStudioVersion = 14.0.24720.0 MinimumVisualStudioVersion = 10.0.40219.1 Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler", "src\fsharp\FSharp.Compiler\FSharp.Compiler.fsproj", "{2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}" EndProject @@ -120,7 +120,15 @@ Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "XMLFile", "vsintegration\It EndProject Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "VisualFSharpVsix", "vsintegration\VisualFSharpVsix\VisualFSharpVsix.csproj", "{E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}" EndProject +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{A83A9A70-8C33-4253-BF6F-3AADB509F21C}" + ProjectSection(SolutionItems) = preProject + Performance1.psess = Performance1.psess + EndProjectSection +EndProject Global + GlobalSection(Performance) = preSolution + HasPerformanceSessions = true + EndGlobalSection GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU Debug|x86 = Debug|x86 @@ -130,54 +138,6 @@ Global Release|x86 = Release|x86 EndGlobalSection GlobalSection(ProjectConfigurationPlatforms) = postSolution - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Debug|Any CPU.Build.0 = Debug|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Debug|x86.ActiveCfg = Debug|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Debug|x86.Build.0 = Debug|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Proto|Any CPU.ActiveCfg = Proto|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Proto|Any CPU.Build.0 = Proto|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Proto|x86.ActiveCfg = Proto|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Proto|x86.Build.0 = Proto|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Release|Any CPU.ActiveCfg = Release|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Release|Any CPU.Build.0 = Release|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Release|x86.ActiveCfg = Release|Any CPU - {4D7BE558-E6BF-44DA-8CE2-46AA6E0DC2E7}.Release|x86.Build.0 = Release|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Debug|Any CPU.Build.0 = Debug|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Debug|x86.ActiveCfg = Debug|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Debug|x86.Build.0 = Debug|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Proto|Any CPU.ActiveCfg = Proto|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Proto|Any CPU.Build.0 = Proto|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Proto|x86.ActiveCfg = Proto|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Proto|x86.Build.0 = Proto|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Release|Any CPU.ActiveCfg = Release|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Release|Any CPU.Build.0 = Release|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Release|x86.ActiveCfg = Release|Any CPU - {493D19F9-35A4-4D0B-9B25-CA948823B709}.Release|x86.Build.0 = Release|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Debug|Any CPU.Build.0 = Debug|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Debug|x86.ActiveCfg = Debug|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Debug|x86.Build.0 = Debug|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Proto|Any CPU.ActiveCfg = Proto|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Proto|Any CPU.Build.0 = Proto|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Proto|x86.ActiveCfg = Proto|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Proto|x86.Build.0 = Proto|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Release|Any CPU.ActiveCfg = Release|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Release|Any CPU.Build.0 = Release|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Release|x86.ActiveCfg = Release|Any CPU - {530DF8CA-7996-407A-B533-D0C2873257AF}.Release|x86.Build.0 = Release|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Debug|Any CPU.Build.0 = Debug|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Debug|x86.ActiveCfg = Debug|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Debug|x86.Build.0 = Debug|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Proto|Any CPU.ActiveCfg = Proto|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Proto|Any CPU.Build.0 = Proto|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Proto|x86.ActiveCfg = Proto|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Proto|x86.Build.0 = Proto|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Release|Any CPU.ActiveCfg = Release|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Release|Any CPU.Build.0 = Release|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Release|x86.ActiveCfg = Release|Any CPU - {98ABDE09-9E08-49C7-B006-FB3CB5365B54}.Release|x86.Build.0 = Release|Any CPU {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|Any CPU.Build.0 = Debug|Any CPU {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|x86.ActiveCfg = Debug|Any CPU @@ -502,18 +462,6 @@ Global {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|Any CPU.Build.0 = Release|Any CPU {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|x86.ActiveCfg = Release|Any CPU {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|x86.Build.0 = Release|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Debug|Any CPU.Build.0 = Debug|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Debug|x86.ActiveCfg = Debug|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Debug|x86.Build.0 = Debug|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Proto|Any CPU.ActiveCfg = Proto|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Proto|Any CPU.Build.0 = Proto|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Proto|x86.ActiveCfg = Proto|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Proto|x86.Build.0 = Proto|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Release|Any CPU.ActiveCfg = Release|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Release|Any CPU.Build.0 = Release|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Release|x86.ActiveCfg = Release|Any CPU - {CB7D20C4-6506-406D-9144-5342C3595F03}.Release|x86.Build.0 = Release|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|Any CPU.Build.0 = Debug|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|x86.ActiveCfg = Debug|Any CPU @@ -753,14 +701,6 @@ Global {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.Release|Any CPU.Build.0 = Release|Any CPU {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.Release|x86.ActiveCfg = Release|Any CPU {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.Release|x86.Build.0 = Release|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSDebug|Any CPU.ActiveCfg = VSDebug|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSDebug|Any CPU.Build.0 = VSDebug|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSDebug|x86.ActiveCfg = VSDebug|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSDebug|x86.Build.0 = VSDebug|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSRelease|Any CPU.ActiveCfg = VSRelease|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSRelease|Any CPU.Build.0 = VSRelease|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSRelease|x86.ActiveCfg = VSRelease|Any CPU - {1FB1DD07-06AA-45B4-B5AC-20FF5BEE98B6}.VSRelease|x86.Build.0 = VSRelease|Any CPU {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.Debug|Any CPU.Build.0 = Debug|Any CPU {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.Debug|x86.ActiveCfg = Debug|Any CPU @@ -773,14 +713,6 @@ Global {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.Release|Any CPU.Build.0 = Release|Any CPU {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.Release|x86.ActiveCfg = Release|Any CPU {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.Release|x86.Build.0 = Release|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSDebug|Any CPU.ActiveCfg = VSDebug|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSDebug|Any CPU.Build.0 = VSDebug|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSDebug|x86.ActiveCfg = VSDebug|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSDebug|x86.Build.0 = VSDebug|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSRelease|Any CPU.ActiveCfg = VSRelease|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSRelease|Any CPU.Build.0 = VSRelease|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSRelease|x86.ActiveCfg = VSRelease|Any CPU - {E7EC4A3E-9D57-45B8-83F5-EDDFD6CEF090}.VSRelease|x86.Build.0 = VSRelease|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE diff --git a/src/absil/il.fs b/src/absil/il.fs index 8287cfb3aa17..5a0cdee0b60c 100755 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -2063,6 +2063,8 @@ let mkILFormalGenericArgs (gparams:ILGenericParameterDefs) = let mkILFormalBoxedTy tref gparams = mkILBoxedTy tref (mkILFormalGenericArgs gparams) +let mkILFormalNamedTy bx tref gparams = mkILNamedTy bx tref (mkILFormalGenericArgs gparams) + // -------------------------------------------------------------------- // Operations on class etc. defs. // -------------------------------------------------------------------- diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 4a81afa084f8..147f5baf987e 100644 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -1676,6 +1676,7 @@ val mkILTySpecRaw: ILTypeRef * ILGenericArgs -> ILTypeSpec /// Make types. val mkILTy: ILBoxity -> ILTypeSpec -> ILType val mkILNamedTy: ILBoxity -> ILTypeRef -> ILGenericArgsList -> ILType +val mkILNamedTyRaw: ILBoxity -> ILTypeRef -> ILGenericArgs -> ILType val mkILBoxedTy: ILTypeRef -> ILGenericArgsList -> ILType val mkILBoxedTyRaw: ILTypeRef -> ILGenericArgs -> ILType val mkILValueTy: ILTypeRef -> ILGenericArgsList -> ILType @@ -1727,6 +1728,7 @@ val mkILCallSig: ILCallingConv * ILType list * ILType -> ILCallingSignature /// Make generalized verions of possibly-generic types, /// e.g. Given the ILTypeDef for List, return the type "List". val mkILFormalBoxedTy: ILTypeRef -> ILGenericParameterDef list -> ILType +val mkILFormalNamedTy: ILBoxity -> ILTypeRef -> ILGenericParameterDef list -> ILType val mkILFormalTyparsRaw: ILTypes -> ILGenericParameterDefs val mkILFormalTypars: ILType list -> ILGenericParameterDefs diff --git a/src/absil/ilprint.fs b/src/absil/ilprint.fs index 819cfdb74ee1..b8289f30b0f5 100644 --- a/src/absil/ilprint.fs +++ b/src/absil/ilprint.fs @@ -439,12 +439,12 @@ let goutput_alternative_ref env os (alt: IlxUnionAlternative) = output_id os alt.Name; alt.FieldDefs |> Array.toList |> output_parens (output_seq "," (fun os fdef -> goutput_typ env os fdef.Type)) os -let goutput_curef env os (IlxUnionRef(tref,alts,_,_)) = +let goutput_curef env os (IlxUnionRef(_,tref,alts,_,_)) = output_string os " .classunion import "; goutput_tref env os tref; output_parens (output_seq "," (goutput_alternative_ref env)) os (Array.toList alts) -let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(tref,_,_,_),i)) = +let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),i)) = output_string os "class /* classunion */ "; goutput_tref env os tref; goutput_gactuals env os i diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index ac8b23f5b147..282ab07d95ad 100644 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -1261,7 +1261,7 @@ let FindMethodDefIdx cenv mdkey = let (TdKey (tenc2,tname2)) = typeNameOfIdx mdkey2.TypeIdx dprintn ("A method in '"+(String.concat "." (tenc2@[tname2]))+"' had the right name but the wrong signature:") dprintn ("generic arity: "+string mdkey2.GenericArity) - dprintn (sprintf "mdkey2: %A" mdkey2)) + dprintn (sprintf "mdkey2: %+A" mdkey2)) raise MethodDefNotFound diff --git a/src/absil/ilx.fs b/src/absil/ilx.fs index efc5056aac66..d183fe0796ba 100644 --- a/src/absil/ilx.fs +++ b/src/absil/ilx.fs @@ -45,16 +45,17 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef of ILTypeRef * IlxUnionAlternative[] * bool * (* hasHelpers: *) IlxUnionHasHelpers + | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool * (* hasHelpers: *) IlxUnionHasHelpers type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(tref,_,_,_),inst)) = x in mkILBoxedTyRaw tref inst - member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(tref,_,_,_),_)) = x in tref + member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(bx,tref,_,_,_),inst)) = x in mkILNamedTy bx tref inst + member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx,_,_,_,_),_)) = x in bx + member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),_)) = x in tref member x.GenericArgs = let (IlxUnionSpec(_,inst)) = x in inst - member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,alts,_,_),_)) = x in alts - member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,np,_),_)) = x in np - member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,b),_)) = x in b + member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,_,alts,_,_),_)) = x in alts + member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,_,np,_),_)) = x in np + member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,b),_)) = x in b member x.Alternatives = Array.toList x.AlternativesArray member x.Alternative idx = x.AlternativesArray.[idx] member x.FieldDef idx fidx = x.Alternative(idx).FieldDef(fidx) diff --git a/src/absil/ilx.fsi b/src/absil/ilx.fsi index db96d9cdb4cb..b7413fbf6989 100644 --- a/src/absil/ilx.fsi +++ b/src/absil/ilx.fsi @@ -40,7 +40,7 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef of ILTypeRef * IlxUnionAlternative[] * bool (* cudNullPermitted *) * IlxUnionHasHelpers (* cudHasHelpers *) + | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool (* cudNullPermitted *) * IlxUnionHasHelpers (* cudHasHelpers *) type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs @@ -48,6 +48,7 @@ type IlxUnionSpec = member GenericArgs : ILGenericArgs member Alternatives : IlxUnionAlternative list member AlternativesArray : IlxUnionAlternative[] + member Boxity : ILBoxity member TypeRef : ILTypeRef member IsNullPermitted : bool member HasHelpers : IlxUnionHasHelpers diff --git a/src/fsharp/AugmentWithHashCompare.fs b/src/fsharp/AugmentWithHashCompare.fs index 3b4031007c1f..842561c857b2 100644 --- a/src/fsharp/AugmentWithHashCompare.fs +++ b/src/fsharp/AugmentWithHashCompare.fs @@ -110,29 +110,29 @@ let mkCombineHashGenerators g m exprs accv acce = // Build comparison functions for union, record and exception types. //------------------------------------------------------------------------- +let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) + let mkThisVarThatVar g m ty = let thisv,thise = mkThisVar g m ty - let thatv,thate = mkCompGenLocal m "obj" (mkThisTy g ty) - thisv,thatv,thise,thate + let thataddrv,thataddre = mkThatAddrLocal g m ty + thisv,thataddrv,thise,thataddre -let mkThatVarBind g m ty thatv expr = +let mkThatVarBind g m ty thataddrv expr = if isStructTy g ty then let thatv2,_ = mkMutableCompGenLocal m "obj" ty - thatv2,mkCompGenLet m thatv (mkValAddr m (mkLocalValRef thatv2)) expr - else thatv,expr + thatv2,mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv2)) expr + else thataddrv,expr -let mkThatAddrLocal g m ty = - if isStructTy g ty then - mkMutableCompGenLocal m "objCast" (mkByrefTy g ty) - else - mkCompGenLocal m "objCast" ty - let mkBindThatAddr g m ty thataddrv thatv thate expr = if isStructTy g ty then mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr else mkCompGenLet m thataddrv thate expr +let mkDerefThis g m (thisv: Val) thise = + if isByrefTy g thisv.Type then mkAddrGet m (mkLocalValRef thisv) + else thise + let mkCompareTestConjuncts g m exprs = match exprs with | [] -> mkZero g m @@ -186,7 +186,7 @@ let mkRecdCompare g tcref (tycon:Tycon) = let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thatv,thise,thate = mkThisVarThatVar g m ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let compe = mkILCallGetComparer g m let mkTest (fspec:RecdField) = let fty = fspec.FormalType @@ -195,12 +195,12 @@ let mkRecdCompare g tcref (tycon:Tycon) = mkCallGenericComparisonWithComparerOuter g m fty compe (mkRecdFieldGetViaExprAddr(thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr(thate, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr(thataddre, fref, tinst, m)) let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr - let thatv,expr = mkThatVarBind g m ty thatv expr + let thatv,expr = mkThatVarBind g m ty thataddrv expr thisv,thatv, expr @@ -222,7 +222,7 @@ let mkRecdCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_,thate) com (mkRecdFieldGetViaExprAddr(thataddre, fref, tinst, m)) let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise tce expr let expr = mkBindThatAddr g m ty thataddrv tcv tce expr // will be optimized away if not necessary @@ -235,19 +235,19 @@ let mkRecdEquality g tcref (tycon:Tycon) = let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thatv,thise,thate = mkThisVarThatVar g m ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let mkTest (fspec:RecdField) = let fty = fspec.FormalType let fref = tcref.MakeNestedRecdFieldRef fspec let m = fref.Range mkCallGenericEqualityEROuter g m fty (mkRecdFieldGetViaExprAddr(thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr(thate, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr(thataddre, fref, tinst, m)) let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr - let thatv,expr = mkThatVarBind g m ty thatv expr + let thatv,expr = mkThatVarBind g m ty thataddrv expr thisv,thatv,expr /// Build the equality implementation for a record type when parameterized by a comparer @@ -288,12 +288,11 @@ let mkExnEquality g exnref (exnc:Tycon) = let expr = mkEqualsTestConjuncts g m (List.mapi mkTest (exnc.AllInstanceFieldsAsList)) let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) - let dtree = - TDSwitch(thate, - [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), - mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ], - Some(mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget)), - m) + let cases = + [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), + mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ] + let dflt = Some(mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thate,cases,dflt,m) mbuilder.Close(dtree,m,g.bool_ty) let expr = mkBindThatNullEquals g m thise thate expr @@ -313,12 +312,11 @@ let mkExnEqualityWithComparer g exnref (exnc:Tycon) (_thisv,thise) thatobje (tha let expr = mkEqualsTestConjuncts g m (List.mapi mkTest (exnc.AllInstanceFieldsAsList)) let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) - let dtree = - TDSwitch(thataddre, - [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), - mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ], - Some(mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget)), - m) + let cases = + [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), + mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ] + let dflt = mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget) + let dtree = TDSwitch(thate,cases,Some dflt,m) mbuilder.Close(dtree,m,g.bool_ty) let expr = mkBindThatAddr g m g.exn_ty thataddrv thatv thate expr let expr = mkIsInstConditional g m g.exn_ty thatobje thatv expr (mkFalse g m) @@ -330,8 +328,7 @@ let mkUnionCompare g tcref (tycon:Tycon) = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thise = mkCompGenLocal m "this" ty - let thatv,thate = mkCompGenLocal m "obj" ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty let compe = mkILCallGetComparer g m @@ -341,30 +338,29 @@ let mkUnionCompare g tcref (tycon:Tycon) = let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericComparisonWithComparerOuter g m argty.FormalType - compe - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thate,cref,tinst,m)) - (mkCompareTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericComparisonWithComparerOuter g m argty.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + Some (mkCase(Test.UnionCase(cref,tinst),mbuilder.AddResultTarget(test,SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkZero g m else - let dtree = - TDSwitch(thise, - (nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare")), - (if isNil nullary then None - else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget))), - m) + let cases = nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare") + let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thise, cases, dflt,m) mbuilder.Close(dtree,m,g.int_ty) let expr = @@ -375,53 +371,56 @@ let mkUnionCompare g tcref (tycon:Tycon) = expr (mkAsmExpr ([ IL.AI_sub ],[], [thistage; thattage],[g.int_ty],m))in mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thate,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = mkBindNullComparison g m thise thate expr - thisv,thatv, expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr + thisv,thataddrv, expr /// Build the comparison implementation for a union type when parameterized by a comparer -let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (thatv,thate) compe = +let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatv,thate) compe = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty let thataddrv,thataddre = mkThatAddrLocal g m ty + let tcv,tce = mkCompGenLocal m "objTemp" ty // let tcv = thate let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericComparisonWithComparerOuter g m argty.FormalType - compe - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thataddre,cref,tinst,m)) - (mkCompareTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericComparisonWithComparerOuter g m argty.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some (mkCase(Test.UnionCase(cref,tinst),mbuilder.AddResultTarget(test,SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkZero g m else - let dtree = - TDSwitch(thise, - (nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare")), - (if isNil nullary then None - else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget))), - m) + let cases = nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare") + let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thise, cases, dflt,m) mbuilder.Close(dtree,m,g.int_ty) let expr = @@ -432,13 +431,15 @@ let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (thatv,thate expr (mkAsmExpr ([ IL.AI_sub ],[], [thistage; thattage],[g.int_ty],m))in mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thataddre,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = mkBindNullComparison g m thise thate expr - let expr = mkBindThatAddr g m ty thataddrv thatv thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise tce expr + let expr = mkBindThatAddr g m ty thataddrv tcv tce expr + // will be optimized away if not necessary + let expr = mkCompGenLet m tcv thate expr expr @@ -447,8 +448,7 @@ let mkUnionEquality g tcref (tycon:Tycon) = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thise = mkCompGenLocal m "this" ty - let thatv,thate = mkCompGenLocal m "obj" ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty @@ -457,27 +457,31 @@ let mkUnionEquality g tcref (tycon:Tycon) = let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericEqualityEROuter g m argty.FormalType - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thate,cref,tinst,m)) - (mkEqualsTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericEqualityEROuter g m argty.FormalType + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some (mkCase(Test.UnionCase(cref,tinst), mbuilder.AddResultTarget(test, SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkTrue g m else - let dtree = - TDSwitch(thise,List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary, - (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget))), - m) + let cases = List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary + let dflt = (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget))) + let dtree = TDSwitch(thise, cases, dflt, m) mbuilder.Close(dtree,m,g.bool_ty) let expr = @@ -489,13 +493,14 @@ let mkUnionEquality g tcref (tycon:Tycon) = (mkFalse g m) mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thate,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = mkBindThatNullEquals g m thise thate expr - thisv,thatv, expr + let thatv,expr = mkThatVarBind g m ty thataddrv expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr + thisv,thatv,expr /// Build the equality implementation for a union type when parameterized by a comparer @@ -512,28 +517,34 @@ let mkUnionEqualityWithComparer g tcref (tycon:Tycon) (_thisv,thise) thatobje (t let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericEqualityWithComparerOuter g m argty.FormalType - compe - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) + let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thataddre,cref,tinst,m)) - (mkEqualsTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericEqualityWithComparerOuter g m argty.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some (mkCase(Test.UnionCase(cref,tinst), mbuilder.AddResultTarget (test, SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkTrue g m else - let dtree = - TDSwitch(thise,List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary, - (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget))), - m) + let cases = List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary + let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thise, cases, dflt, m) mbuilder.Close(dtree,m,g.bool_ty) let expr = @@ -545,9 +556,9 @@ let mkUnionEqualityWithComparer g tcref (tycon:Tycon) (_thisv,thise) thatobje (t (mkFalse g m) mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thataddre,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) let expr = mkBindThatAddr g m ty thataddrv thatv thate expr let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) @@ -605,25 +616,32 @@ let mkUnionHashWithComparer g tcref (tycon:Tycon) compe = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) let accv,acce = mkMutableCompGenLocal m "i" g.int_ty let mkCase i ucase1 = - let c1ref = tcref.MakeNestedUnionCaseRef ucase1 - let ucv,ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) - let m = c1ref.Range - let mkHash j (rfield:RecdField) = - let fty = rfield.FormalType - let e = mkUnionCaseFieldGetProven(ucve, c1ref, tinst, j, m) - mkCallGenericHashWithComparerOuter g m fty compe e - mkCase(Test.UnionCase(c1ref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m ucv - (mkUnionCaseProof(thise,c1ref,tinst,m)) + let c1ref = tcref.MakeNestedUnionCaseRef ucase1 + let m = c1ref.Range + let mkHash thise j (rfield:RecdField) = + let fty = rfield.FormalType + let e = mkUnionCaseFieldGetProvenViaExprAddr(thise, c1ref, tinst, j, m) + mkCallGenericHashWithComparerOuter g m fty compe e + + let test = + if tycon.IsStructOrEnumTycon then + mkCompGenSequential m + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCombineHashGenerators g m (List.mapi (mkHash thise) ucase1.RecdFields) (mkLocalValRef accv) acce) + else + let ucv,ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) + mkCompGenLet m ucv + (mkUnionCaseProof (thise,c1ref,tinst,m)) (mkCompGenSequential m - (mkValSet m (mkLocalValRef accv) (mkInt g m i)) - (mkCombineHashGenerators g m (List.mapi mkHash ucase1.RecdFields) (mkLocalValRef accv) acce)), - SuppressSequencePointAtTarget)) - let dtree = TDSwitch(thise,List.mapi mkCase ucases, None,m) + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCombineHashGenerators g m (List.mapi (mkHash ucve) ucase1.RecdFields) (mkLocalValRef accv) acce)) + + mkCase(Test.UnionCase(c1ref,tinst),mbuilder.AddResultTarget(test,SuppressSequencePointAtTarget)) + + let dtree = TDSwitch(thise, List.mapi mkCase ucases, None,m) let stmt = mbuilder.Close(dtree,m,g.int_ty) let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = mkBindNullHash g m thise expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullHash g m thise expr thisv,expr diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index fbab553659d0..3800e29755b2 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -2575,11 +2575,21 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait | true, true, 1 -> Some (mkStaticRecdFieldSet (rfref, tinst, argExprs.[0], m)) | true, false, 2 -> - Some (mkRecdFieldSet g (argExprs.[0], rfref, tinst, argExprs.[1], m)) + // If we resolve to an instance field on a struct and we haven't yet taken + // the address of the object then go do that + if rfref.Tycon.IsStructOrEnumTycon && not (isByrefTy g (tyOfExpr g argExprs.[0])) then + let h = List.head argExprs + let wrap,h' = mkExprAddrOfExpr g true false DefinitelyMutates h None m + Some (wrap (mkRecdFieldSetViaExprAddr (h', rfref, tinst, argExprs.[1], m))) + else + Some (mkRecdFieldSetViaExprAddr (argExprs.[0], rfref, tinst, argExprs.[1], m)) | false, true, 0 -> Some (mkStaticRecdFieldGet (rfref, tinst, m)) | false, false, 1 -> - Some (mkRecdFieldGet g (argExprs.[0], rfref, tinst, m)) + if rfref.Tycon.IsStructOrEnumTycon && isByrefTy g (tyOfExpr g argExprs.[0]) then + Some (mkRecdFieldGetViaExprAddr (argExprs.[0], rfref, tinst, m)) + else + Some (mkRecdFieldGet g (argExprs.[0], rfref, tinst, m)) | _ -> None ResultD res | Choice3Of4 expr -> ResultD (Some (MakeApplicationAndBetaReduce g (expr, tyOfExpr g expr, [], argExprs, m))) diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index 28b15426e039..c52663bd402f 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1301,4 +1301,5 @@ estApplyStaticArgumentsForMethodNotImplemented,"A type provider implemented GetS 3196,fsharpCoreNotFoundToBeCopied,"Cannot find FSharp.Core.dll in compiler's directory" 3197,etMissingStaticArgumentsToMethod,"This provided method requires static parameters" 3198,considerUpcast,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using 'upcast' instead of 'downcast'." -3198,considerUpcastOperator,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using the :> (upcast) operator instead of the :?> (downcast) operator." \ No newline at end of file +3198,considerUpcastOperator,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using the :> (upcast) operator instead of the :?> (downcast) operator." +3199,tcStructUnionMultiCase,"A union type which is a struct must have only one case." \ No newline at end of file diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs index 42f038b67bcc..52ea6fbf3889 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs @@ -1,10 +1,25 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. -namespace FSharp.Core.Unittests.FSharp_Core.Microsoft_FSharp_Core +module FSharp.Core.Unittests.FSharp_Core.Microsoft_FSharp_Core.DiscriminatedUnionTypes open System open System.Numerics +open System.Reflection +open System.Runtime.InteropServices open FSharp.Core.Unittests.LibraryTestFx open NUnit.Framework +open FsCheck +open FsCheck.PropOperators + +#if FX_RESHAPED_REFLECTION +open FSharp.Reflection.FSharpReflectionExtensions + +[] +module PrimReflectionAdapters = + + type System.Type with + member this.IsValueType = this.GetTypeInfo().IsValueType +#endif + type EnumUnion = | A @@ -95,4 +110,119 @@ type UseUnionsWithData() = | _ -> Assert.Fail() match a2 with | Alpha x when x = 2 -> () - | _ -> Assert.Fail() \ No newline at end of file + | _ -> Assert.Fail() + +[] +type StructUnion = SU of C : int * D : int + +let private hasAttribute<'T,'Attr>() = + typeof<'T>.GetTypeInfo().GetCustomAttributes() |> Seq.exists (fun x -> x.GetType() = typeof<'Attr>) + + +let [] ``struct unions hold [] metadata`` () = + Assert.IsTrue (hasAttribute()) + + +let [] ``struct unions are comparable`` () = + Check.QuickThrowOnFailure <| + fun (i1:int) (i2:int) -> + i1 <> i2 ==> + let sr1 = SU (i1, i2) + let sr2 = SU (i1, i2) + let sr3 = SU (i2, i1) + (sr1 = sr2) |@ "sr1 = sr2" .&. + (sr1 <> sr3) |@ "sr1 <> sr3" .&. + (sr1.Equals sr2) |@ "sr1.Equals sr2" + + +let [] ``struct unions support pattern matching`` () = + Check.QuickThrowOnFailure <| + fun (i1:int) (i2:int) -> + let sr1 = SU(i1, i2) + (match sr1 with + | SU(c,d) when c = i1 && d = i2 -> true + | _ -> false) + |@ "with pattern match on struct union" .&. + (sr1 |> function + | SU(c,d) when c = i1 && d = i2 -> true + | _ -> false) + |@ "function pattern match on struct union" + + +let [] ``struct unions support let binds using `` () = + Check.QuickThrowOnFailure <| + fun (i1:int) (i2:int) -> + let sr1 = SU(i1,i2) + let (SU (c1,d2)) as sr2 = sr1 + (sr1 = sr2) |@ "sr1 = sr2" .&. + (c1 = i1 && d2 = i2) |@ "c1 = i1 && d2 = i2" + + +let [] ``struct unions support function argument bindings`` () = + Check.QuickThrowOnFailure <| + fun (i1:int) (i2:int) -> + let sr1 = SU(i1,i2) + let test sr1 (SU (c1,d2) as sr2) = + sr1 = sr2 && c1 = i1 && d2 = i2 + test sr1 sr1 + + + +[] +[] +type ComparisonStructUnion = + | SU2 of int * int + member x.C1 = (match x with SU2(a,b) -> a) + member x.C2 = (match x with SU2(a,b) -> b) + override self.Equals other = + match other with + | :? ComparisonStructUnion as o -> (self.C1 + self.C2) = (o.C1 + o.C2) + | _ -> false + + override self.GetHashCode() = hash self + interface IComparable with + member self.CompareTo other = + match other with + | :? ComparisonStructUnion as o -> compare (self.C1 + self.C2) (o.C1 + o.C2) + | _ -> invalidArg "other" "cannot compare values of different types" + + +[] +let ``struct unions support []`` () = + Check.QuickThrowOnFailure <| + fun (i1:int) (i2:int) -> + let sr1 = SU2(i1,i2) + let sr2 = SU2(i1,i2) + (sr1.Equals sr2) + + +[] +let ``struct unions support []`` () = + Check.QuickThrowOnFailure <| + fun (i1:int) (i2:int) (k1:int) (k2:int) -> + let sr1 = SU2(i1,i2) + let sr2 = SU2(k1,k2) + if sr1 > sr2 then compare sr1 sr2 = 1 + elif sr1 < sr2 then compare sr1 sr2 = -1 + elif sr1 = sr2 then compare sr1 sr2 = 0 + else false + + +[] +let ``struct unions hold [] [] metadata`` () = + Assert.IsTrue (hasAttribute()) + Assert.IsTrue (hasAttribute()) + + +[] +[] +type NoComparisonStructUnion = + | SU3 of int * int + + + +[] +let ``struct unions hold [] [] metadata`` () = + Assert.IsTrue (hasAttribute()) + Assert.IsTrue (hasAttribute()) + diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index e7f357eb8253..55ee5241a284 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -473,7 +473,8 @@ and GenUnionRef amap m g (tcref: TyconRef) = altFields=GenUnionCaseRef amap m g tyenvinner i cspec.RecdFieldsArray }) let nullPermitted = IsUnionTypeWithNullAsTrueValue g tycon let hasHelpers = ComputeUnionHasHelpers g tcref - IlxUnionRef(tref,alternatives,nullPermitted,hasHelpers)) + let boxity = (if tcref.IsStructOrEnumTycon then ILBoxity.AsValue else ILBoxity.AsObject) + IlxUnionRef(boxity, tref,alternatives,nullPermitted,hasHelpers)) and ComputeUnionHasHelpers g (tcref : TyconRef) = if tyconRefEq g tcref g.unit_tcr_canon then NoHelpers @@ -1751,6 +1752,8 @@ let rec GenExpr cenv (cgbuf:CodeGenBuffer) eenv sp expr sequel = GenGetExnField cenv cgbuf eenv (e,ecref,n,m) sequel | TOp.UnionCaseFieldGet(ucref,n),[e],_ -> GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel + | TOp.UnionCaseFieldGetAddr(ucref,n),[e],_ -> + GenGetUnionCaseFieldAddr cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel | TOp.UnionCaseTagGet ucref,[e],_ -> GenGetUnionCaseTag cenv cgbuf eenv (e,ucref,tyargs,m) sequel | TOp.UnionCaseProof ucref,[e],_ -> @@ -2181,12 +2184,13 @@ and GenUnionCaseProof cenv cgbuf eenv (e,ucref,tyargs,m) sequel = GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs let fty = EraseUnions.GetILTypeForAlternative cuspec idx - EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,cuspec,idx) + let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef + EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,avoidHelpers,cuspec,idx) CG.EmitInstrs cgbuf (pop 1) (Push [fty]) [ ] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel = - assert (isProvenUnionCaseTy (tyOfExpr cenv.g e)); + assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr cenv.g e)); GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs @@ -2195,6 +2199,16 @@ and GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel = CG.EmitInstrs cgbuf (pop 1) (Push [fty]) (EraseUnions.mkLdData (avoidHelpers, cuspec, idx, n)); GenSequel cenv eenv.cloc cgbuf sequel +and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel = + assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr cenv.g e)); + + GenExpr cenv cgbuf eenv SPSuppress e Continue; + let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs + let fty = actualTypOfIlxUnionField cuspec idx n + let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef + CG.EmitInstrs cgbuf (pop 1) (Push [ILType.Byref fty]) (EraseUnions.mkLdDataAddr (avoidHelpers, cuspec, idx, n)); + GenSequel cenv eenv.cloc cgbuf sequel + and GenGetUnionCaseTag cenv cgbuf eenv (e,tcref,tyargs,m) sequel = GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec = GenUnionSpec cenv.amap m cenv.g eenv.tyenv tcref tyargs @@ -2206,7 +2220,8 @@ and GenGetUnionCaseTag cenv cgbuf eenv (e,tcref,tyargs,m) sequel = and GenSetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,e2,m) sequel = GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs - EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,cuspec,idx) + let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef + EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,avoidHelpers,cuspec,idx) CG.EmitInstrs cgbuf (pop 1) (Push [cuspec.EnclosingType]) [ ] // push/pop to match the line above GenExpr cenv cgbuf eenv SPSuppress e2 Continue; CG.EmitInstrs cgbuf (pop 2) Push0 (EraseUnions.mkStData (cuspec, idx, n)); @@ -4247,12 +4262,17 @@ and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defau let failureTree = (match defaultTargetOpt with None -> cases.Tail.Head.CaseTree | Some d -> d) GenDecisionTreeTest cenv eenv.cloc cgbuf stackAtTargets e None eenv (if b then successTree else failureTree) (if b then failureTree else successTree) targets repeatSP targetInfos sequel - // optimize a single test for a type constructor to an "isdata" test - much + // // Remove a single test for a union case . Union case tests are always exa + //| [ TCase(Test.UnionCase _, successTree) ] when (defaultTargetOpt.IsNone) -> + // GenDecisionTreeAndTargetsInner cenv cgbuf inplabOpt stackAtTargets eenv successTree targets repeatSP targetInfos sequel + // //GenDecisionTree cenv eenv.cloc cgbuf stackAtTargets e (Some (pop 1, Push [cenv.g.ilg.typ_bool], Choice1Of2 (avoidHelpers, cuspec, idx))) eenv successTree failureTree targets repeatSP targetInfos sequel + + // Optimize a single test for a union case to an "isdata" test - much // more efficient code, and this case occurs in the generated equality testers where perf is important - | TCase(Test.UnionCase(c,tyargs), successTree) :: rest when List.length rest = (match defaultTargetOpt with None -> 1 | Some _ -> 0) -> + | TCase(Test.UnionCase(c,tyargs), successTree) :: rest when rest.Length = (match defaultTargetOpt with None -> 1 | Some _ -> 0) -> let failureTree = match defaultTargetOpt with - | None -> cases.Tail.Head.CaseTree + | None -> rest.Head.CaseTree | Some tg -> tg let cuspec = GenUnionSpec cenv.amap m cenv.g eenv.tyenv c.TyconRef tyargs let idx = c.Index @@ -6116,7 +6136,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = | TTyconInterface -> ILTypeDefKind.Interface | TTyconEnum -> ILTypeDefKind.Enum | TTyconDelegate _ -> ILTypeDefKind.Delegate - | TRecdRepr _ when tycon.IsStructRecordTycon -> ILTypeDefKind.ValueType + | TRecdRepr _ | TUnionRepr _ when tycon.IsStructOrEnumTycon -> ILTypeDefKind.ValueType | _ -> ILTypeDefKind.Class let requiresExtraField = @@ -6285,13 +6305,15 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = (true,emptyILLocals,2, nonBranchingInstrsToCode ([ // load the hardwired format string - I_ldstr "%+0.8A"; + yield I_ldstr "%+0.8A"; // make the printf format object - mkNormalNewobj newFormatMethSpec; + yield mkNormalNewobj newFormatMethSpec; // call sprintf - mkNormalCall sprintfMethSpec; + yield mkNormalCall sprintfMethSpec; // call the function returned by sprintf - mkLdarg0 ] @ + yield mkLdarg0 + if ilThisTy.Boxity = ILBoxity.AsValue then + yield mkNormalLdobj ilThisTy ] @ callInstrs), None)) yield ilMethodDef |> AddSpecialNameFlag |> AddNonUserCompilerGeneratedAttribs cenv.g @@ -6319,7 +6341,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = relevantFields |> List.map (fun (_,ilFieldName,_,_,_,ilPropType,_,fspec) -> (fspec.Name,ilFieldName,ilPropType)) - let isStructRecord = tycon.IsStructRecordTycon + let isStructRecord = tycon.IsStructRecordOrUnionTycon // No type spec if the record is a value type let spec = if isStructRecord then None else Some(cenv.g.ilg.tspec_Object) @@ -6506,7 +6528,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = InitSemantics=ILTypeInit.BeforeField; IsSealed=true; IsAbstract=false; - tdKind= ILTypeDefKind.Class + tdKind= (if tycon.IsStructOrEnumTycon then ILTypeDefKind.ValueType else ILTypeDefKind.Class) Fields = ilFields; Events= ilEvents; Properties = ilProperties; @@ -6518,7 +6540,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = NestedTypes=emptyILTypeDefs; Encoding= ILDefaultPInvokeEncoding.Auto; Implements= mkILTypes ilIntfTys; - Extends= Some cenv.g.ilg.typ_Object; + Extends= Some (if tycon.IsStructOrEnumTycon then cenv.g.ilg.typ_ValueType else cenv.g.ilg.typ_Object) SecurityDecls= emptyILSecurityDecls; HasSecurity=false } let tdef2 = EraseUnions.mkClassUnionDef cenv.g.ilg tref tdef cuinfo diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index 9ebd2bafafe7..52345ff8c43c 100755 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -1656,7 +1656,7 @@ let private ResolveObjectConstructorPrim (ncenv:NameResolver) edenv resInfo m ad success (resInfo, Item.FakeInterfaceCtor typ) else let defaultStructCtorInfo = - if (isStructTy g typ && not(isRecdTy g typ) && not(ctorInfos |> List.exists (fun x -> x.IsNullary))) then + if (isStructTy g typ && not (isRecdTy g typ) && not (isUnionTy g typ) && not(ctorInfos |> List.exists (fun x -> x.IsNullary))) then [DefaultStructCtor(g,typ)] else [] if (isNil defaultStructCtorInfo && isNil ctorInfos) || not (isAppTy g typ) then diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 0bb9b2dfe871..e3451d188f1e 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -1320,7 +1320,8 @@ and OpHasEffect g op = | TOp.ExnFieldGet(ecref,n) -> isExnFieldMutable ecref n | TOp.RefAddrGet -> false | TOp.ValFieldGet rfref -> rfref.RecdField.IsMutable || (TryFindTyconRefBoolAttribute g Range.range0 g.attrib_AllowNullLiteralAttribute rfref.TyconRef = Some(true)) - | TOp.ValFieldGetAddr _rfref -> true (* check *) + | TOp.ValFieldGetAddr rfref -> rfref.RecdField.IsMutable (* data is immutable, so taking address is ok *) + | TOp.UnionCaseFieldGetAddr _ -> false (* data is immutable, so taking address is ok *) | TOp.LValueOp (LGetAddr,lv) -> lv.IsMutable | TOp.UnionCaseFieldSet _ | TOp.ExnFieldSet _ @@ -1928,6 +1929,7 @@ and OptimizeExprOpFallback cenv env (op,tyargs,args',m) arginfos valu = | TOp.Array | TOp.For _ | TOp.While _ | TOp.TryCatch _ | TOp.TryFinally _ | TOp.ILCall _ | TOp.TraitCall _ | TOp.LValueOp _ | TOp.ValFieldSet _ | TOp.UnionCaseFieldSet _ | TOp.RefAddrGet | TOp.Coerce | TOp.Reraise + | TOp.UnionCaseFieldGetAddr _ | TOp.ExnFieldSet _ -> 1,valu | TOp.Recd (ctorInfo,tcref) -> let finfos = tcref.AllInstanceFieldsAsList diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 0dae5cdfbf2e..22400641b797 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -375,7 +375,7 @@ let getDiscrimOfPattern g tpinst t = | TPat_array (args,ty,_m) -> Some(Test.ArrayLength (args.Length,ty)) | TPat_query ((pexp,resTys,apatVrefOpt,idx,apinfo),_,_m) -> - Some(Test.ActivePatternCase (pexp, instTypes tpinst resTys, apatVrefOpt,idx,apinfo)) + Some(Test.ActivePatternCase (pexp, instTypes tpinst resTys, apatVrefOpt, idx, apinfo)) | _ -> None let constOfDiscrim discrim = @@ -897,6 +897,21 @@ let CompilePatternBasic let appexp = mkIsInst tgty argexp matchm Some(vexp),Some(mkInvisibleBind v appexp) + // Any match on a struct union must take the address of its input + | EdgeDiscrim(_i',(Test.UnionCase (ucref, _)),_) :: _rest + when (isNil topgtvs && ucref.Tycon.IsStructRecordOrUnionTycon) -> + + let argexp = GetSubExprOfInput subexpr + let vOpt,addrexp = mkExprAddrOfExprAux g true false NeverMutates argexp None matchm + match vOpt with + | None -> None, None + | Some (v,e) -> + if topv.IsMemberOrModuleBinding then + AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + Some addrexp, Some (mkInvisibleBind v e) + + + #if OPTIMIZE_LIST_MATCHING | [EdgeDiscrim(_, ListConsDiscrim g tinst,m); EdgeDiscrim(_, ListEmptyDiscrim g _, _)] | [EdgeDiscrim(_, ListEmptyDiscrim g _, _); EdgeDiscrim(_, ListConsDiscrim g tinst, m)] @@ -915,7 +930,7 @@ let CompilePatternBasic #endif // Active pattern matches: create a variable to hold the results of executing the active pattern. - | (EdgeDiscrim(_,(Test.ActivePatternCase(pexp,resTys,_resPreBindOpt,_,apinfo)),m) :: _) -> + | (EdgeDiscrim(_,(Test.ActivePatternCase(pexp,resTys,_,_,apinfo)),m) :: _) -> if debug then dprintf "Building result var for active pattern...\n"; if nonNil topgtvs then error(InternalError("Unexpected generalized type variables when compiling an active pattern",m)); @@ -957,13 +972,14 @@ let CompilePatternBasic #endif (isNil topgtvs && not topv.IsMemberOrModuleBinding && + not ucref.Tycon.IsStructRecordOrUnionTycon && ucref.UnionCase.RecdFields.Length >= 1 && ucref.Tycon.UnionCasesArray.Length > 1) -> let v,vexp = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy ucref tinst) let argexp = GetSubExprOfInput subexpr - let appexp = mkUnionCaseProof(argexp, ucref,tinst,m) - Some(vexp),Some(mkInvisibleBind v appexp) + let appexp = mkUnionCaseProof (argexp, ucref,tinst,m) + Some vexp,Some(mkInvisibleBind v appexp) | _ -> None,None @@ -1052,11 +1068,14 @@ let CompilePatternBasic if (hasParam && i = i') || (discrimsEq g discrim (Option.get (getDiscrimOfPattern pat))) then let aparity = apinfo.Names.Length let accessf' j tpinst _e' = + assert resPreBindOpt.IsSome if aparity <= 1 then Option.get resPreBindOpt else let ucref = mkChoiceCaseRef g m aparity idx - mkUnionCaseFieldGetUnproven(Option.get resPreBindOpt,ucref,instTypes tpinst resTys,j,exprm) + // TODO: In the future we will want active patterns to be able to return struct-unions + // In that eventuality, we need to check we are taking the address correctly + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get resPreBindOpt,ucref,instTypes tpinst resTys,j,exprm) mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j)) elif hasParam then @@ -1068,7 +1087,9 @@ let CompilePatternBasic else if i = i' then let accessf' _j tpinst _ = - mkUnionCaseFieldGetUnproven(Option.get resPreBindOpt, mkSomeCase g, instTypes tpinst resTys, 0, exprm) + // TODO: In the future we will want active patterns to be able to return struct-unions + // In that eventuality, we need to check we are taking the address correctly + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get resPreBindOpt, mkSomeCase g, instTypes tpinst resTys, 0, exprm) mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j)) else // Successful active patterns don't refute other patterns @@ -1080,12 +1101,12 @@ let CompilePatternBasic let accessf' j tpinst e' = #if OPTIMIZE_LIST_MATCHING match resPreBindOpt with - | Some e -> mkUnionCaseFieldGetProven(e,ucref1,tinst,j,exprm) + | Some e -> mkUnionCaseFieldGetProvenViaExprAddr g (e,ucref1,tinst,j,exprm) | None -> #endif match resPostBindOpt with - | Some e -> mkUnionCaseFieldGetProven(e,ucref1,tinst,j,exprm) - | None -> mkUnionCaseFieldGetUnproven(accessf tpinst e',ucref1,instTypes tpinst tyargs,j,exprm) + | Some e -> mkUnionCaseFieldGetProvenViaExprAddr (e,ucref1,tinst,j,exprm) + | None -> mkUnionCaseFieldGetUnprovenViaExprAddr (accessf tpinst e',ucref1,instTypes tpinst tyargs,j,exprm) mkSubFrontiers path accessf' active' argpats (fun path j -> PathUnionConstr(path,ucref1,tyargs,j)) | Test.UnionCase _ -> diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 275ffbe2137f..9519c65f50de 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -731,22 +731,41 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = CheckTypeInstNoByrefs cenv env m tyargs; CheckExprDirectArgs cenv env [arg1]; (* See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 *) CheckExprs cenv env [arg2] (* Property setters on mutable structs come through here (TBC). *) + | TOp.Coerce,[_ty1;_ty2],[x],_arity -> CheckTypeInstNoByrefs cenv env m tyargs; CheckExprInContext cenv env x context + | TOp.Reraise,[_ty1],[],_arity -> CheckTypeInstNoByrefs cenv env m tyargs + | TOp.ValFieldGetAddr rfref,tyargs,[],_ -> if context <> DirectArg && cenv.reportErrors then errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)); CheckTypeInstNoByrefs cenv env m tyargs (* NOTE: there are no arg exprs to check in this case *) + | TOp.ValFieldGetAddr rfref,tyargs,[rx],_ -> if context <> DirectArg && cenv.reportErrors then errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)); (* This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. *) CheckTypeInstNoByrefs cenv env m tyargs; CheckExprInContext cenv env rx DirectArg (* allow rx to be byref here *) + + | TOp.UnionCaseFieldGet _,_,[arg1],_arity -> + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprInContext cenv env arg1 DirectArg + + | TOp.UnionCaseTagGet _,_,[arg1],_arity -> + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprInContext cenv env arg1 DirectArg + + | TOp.UnionCaseFieldGetAddr (uref, _idx),tyargs,[rx],_ -> + if context <> DirectArg && cenv.reportErrors then + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(uref.CaseName), m)) + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprInContext cenv env rx DirectArg // allow rx to be byref here + | TOp.ILAsm (instrs,tys),_,_,_ -> CheckTypeInstPermitByrefs cenv env m tys; CheckTypeInstNoByrefs cenv env m tyargs; @@ -887,9 +906,9 @@ and CheckDecisionTree cenv env x = | TDSwitch (e,cases,dflt,m) -> CheckDecisionTreeSwitch cenv env (e,cases,dflt,m) and CheckDecisionTreeSwitch cenv env (e,cases,dflt,m) = - CheckExpr cenv env e; - List.iter (fun (TCase(discrim,e)) -> CheckDecisionTreeTest cenv env m discrim; CheckDecisionTree cenv env e) cases; - Option.iter (CheckDecisionTree cenv env) dflt + CheckExprInContext cenv env e DirectArg // can be byref for struct union switch + cases |> List.iter (fun (TCase(discrim,e)) -> CheckDecisionTreeTest cenv env m discrim; CheckDecisionTree cenv env e) + dflt |> Option.iter (CheckDecisionTree cenv env) and CheckDecisionTreeTest cenv env m discrim = match discrim with diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 22090236d4b6..3361b5ec54f8 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -433,6 +433,9 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. | TOp.ValFieldGetAddr(_rfref),_tyargs,_ -> wfail(Error(FSComp.SR.crefQuotationsCantContainAddressOf(), m)) + | TOp.UnionCaseFieldGetAddr _,_tyargs,_ -> + wfail(Error(FSComp.SR.crefQuotationsCantContainAddressOf(), m)) + | TOp.ValFieldGet(_rfref),_tyargs,[] -> wfail(Error(FSComp.SR.crefQuotationsCantContainStaticFieldRef(),m)) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index d82e0671bf7b..fd4e2c2f6be6 100755 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1181,24 +1181,32 @@ let mkStaticRecdFieldGetAddr(fref,tinst,m) = Expr.Op (TOp.ValFieldGetAd let mkStaticRecdFieldGet(fref,tinst,m) = Expr.Op (TOp.ValFieldGet(fref), tinst, [],m) let mkStaticRecdFieldSet(fref,tinst,e,m) = Expr.Op (TOp.ValFieldSet(fref), tinst, [e],m) -let mkRecdFieldSetViaExprAddr(e1,fref,tinst,e2,m) = Expr.Op (TOp.ValFieldSet(fref), tinst, [e1;e2],m) +let mkRecdFieldSetViaExprAddr (e1,fref,tinst,e2,m) = Expr.Op (TOp.ValFieldSet(fref), tinst, [e1;e2],m) -let mkUnionCaseTagGet(e1,cref,tinst,m) = Expr.Op (TOp.UnionCaseTagGet(cref), tinst, [e1],m) -let mkUnionCaseProof(e1,cref,tinst,m) = Expr.Op (TOp.UnionCaseProof(cref), tinst, [e1],m) +let mkUnionCaseTagGetViaExprAddr (e1,cref,tinst,m) = Expr.Op (TOp.UnionCaseTagGet(cref), tinst, [e1],m) -/// Build a 'get' expression for something we've already determined to be a particular union case, and where the -/// input expression has 'TType_ucase', which is an F# compiler internal "type" -let mkUnionCaseFieldGetProven(e1,cref,tinst,j,m) = Expr.Op (TOp.UnionCaseFieldGet(cref,j), tinst, [e1],m) +/// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) +let mkUnionCaseProof (e1,cref:UnionCaseRef,tinst,m) = if cref.Tycon.IsStructOrEnumTycon then e1 else Expr.Op (TOp.UnionCaseProof(cref), tinst, [e1],m) + +/// Build a 'TOp.UnionCaseFieldGet' expression for something we've already determined to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +let mkUnionCaseFieldGetProvenViaExprAddr (e1,cref,tinst,j,m) = Expr.Op (TOp.UnionCaseFieldGet(cref,j), tinst, [e1],m) + +/// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +let mkUnionCaseFieldGetAddrProvenViaExprAddr (e1,cref,tinst,j,m) = Expr.Op (TOp.UnionCaseFieldGetAddr(cref,j), tinst, [e1],m) /// Build a 'get' expression for something we've already determined to be a particular union case, but where /// the static type of the input is not yet proven to be that particular union case. This requires a type /// cast to 'prove' the condition. -let mkUnionCaseFieldGetUnproven(e1,cref,tinst,j,m) = mkUnionCaseFieldGetProven(mkUnionCaseProof(e1,cref,tinst,m),cref,tinst,j,m) +let mkUnionCaseFieldGetUnprovenViaExprAddr (e1,cref,tinst,j,m) = mkUnionCaseFieldGetProvenViaExprAddr(mkUnionCaseProof(e1,cref,tinst,m),cref,tinst,j,m) -let mkUnionCaseFieldSet(e1,cref,tinst,j,e2,m) = Expr.Op (TOp.UnionCaseFieldSet(cref,j), tinst, [e1;e2],m) +let mkUnionCaseFieldSet (e1,cref,tinst,j,e2,m) = Expr.Op (TOp.UnionCaseFieldSet(cref,j), tinst, [e1;e2],m) -let mkExnCaseFieldGet(e1,ecref,j,m) = Expr.Op (TOp.ExnFieldGet(ecref,j), [],[e1],m) -let mkExnCaseFieldSet(e1,ecref,j,e2,m) = Expr.Op (TOp.ExnFieldSet(ecref,j), [],[e1;e2],m) +let mkExnCaseFieldGet (e1,ecref,j,m) = Expr.Op (TOp.ExnFieldGet(ecref,j), [],[e1],m) +let mkExnCaseFieldSet (e1,ecref,j,e2,m) = Expr.Op (TOp.ExnFieldSet(ecref,j), [],[e1;e2],m) let mkDummyLambda g (e:Expr,ety) = let m = e.Range @@ -1310,6 +1318,9 @@ let actualTyOfRecdFieldForTycon tycon tinst (fspec:RecdField) = let actualTyOfRecdFieldRef (fref:RecdFieldRef) tinst = actualTyOfRecdFieldForTycon fref.Tycon tinst fref.RecdField +let actualTyOfUnionFieldRef (fref:UnionCaseRef) n tinst = + actualTyOfRecdFieldForTycon fref.Tycon tinst (fref.FieldByIndex(n)) + //--------------------------------------------------------------------------- // Apply type functions to types @@ -4130,6 +4141,7 @@ and accFreeInOp opts op acc = // Things containing just a union case reference | TOp.UnionCaseProof cr | TOp.UnionCase cr + | TOp.UnionCaseFieldGetAddr (cr,_) | TOp.UnionCaseFieldGet (cr,_) | TOp.UnionCaseFieldSet (cr,_) -> accFreeUnionCaseRef opts cr acc @@ -4538,7 +4550,7 @@ and remapExpr g (compgen:ValCopyFlag) (tmenv:Remap) x = List.map (remapMethod g compgen tmenvinner) overrides, List.map (remapInterfaceImpl g compgen tmenvinner) iimpls,m) - // Addresses of immutable field may "leak" across assembly boundaries - see CanTakeAddressOfRecdField below. + // Addresses of immutable field may "leak" across assembly boundaries - see CanTakeAddressOfRecdFieldRef below. // This is "ok", in the sense that it is always valid to fix these up to be uses // of a temporary local, e.g. // &(E.RF) --> let mutable v = E.RF in &v @@ -4552,6 +4564,15 @@ and remapExpr g (compgen:ValCopyFlag) (tmenv:Remap) x = let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" (actualTyOfRecdFieldRef rfref tinst) mkCompGenLet m tmp (mkRecdFieldGetViaExprAddr(arg,rfref,tinst,m)) (mkValAddr m (mkLocalValRef tmp)) + | Expr.Op (TOp.UnionCaseFieldGetAddr (uref,cidx),tinst,[arg],m) when + not (uref.FieldByIndex(cidx).IsMutable) && + not (entityRefInThisAssembly g.compilingFslib uref.TyconRef) -> + + let tinst = remapTypes tmenv tinst + let arg = remapExpr g compgen tmenv arg + let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" (actualTyOfUnionFieldRef uref cidx tinst) + mkCompGenLet m tmp (mkUnionCaseFieldGetProvenViaExprAddr(arg,uref,tinst,cidx,m)) (mkValAddr m (mkLocalValRef tmp)) + | Expr.Op (op,tinst,args,m) -> let op' = remapOp tmenv op let tinst' = remapTypes tmenv tinst @@ -5102,6 +5123,7 @@ let rec tyOfExpr g e = | TOp.ValFieldGet(fref) -> actualTyOfRecdFieldRef fref tinst | (TOp.ValFieldSet _ | TOp.UnionCaseFieldSet _ | TOp.ExnFieldSet _ | TOp.LValueOp ((LSet | LByrefSet),_)) ->g.unit_ty | TOp.UnionCaseTagGet _ -> g.int_ty + | TOp.UnionCaseFieldGetAddr(cref,j) -> mkByrefTy g (actualTyOfRecdField (mkTyconRefInst cref.TyconRef tinst) (cref.FieldByIndex j)) | TOp.UnionCaseFieldGet(cref,j) -> actualTyOfRecdField (mkTyconRefInst cref.TyconRef tinst) (cref.FieldByIndex j) | TOp.ExnFieldGet(ecref,j) -> recdFieldTyOfExnDefRefByIdx ecref j | TOp.LValueOp (LByrefGet, v) -> destByrefTy g v.Type @@ -5326,7 +5348,7 @@ let mkAndSimplifyMatch spBind exprm matchm ty tree targets = //------------------------------------------------------------------------- -// mkExprAddrOfExpr +// mkExprAddrOfExprAux //------------------------------------------------------------------------- type Mutates = DefinitelyMutates | PossiblyMutates | NeverMutates @@ -5370,48 +5392,61 @@ let MustTakeAddressOfVal g (v:ValRef) = // We can only take the address of mutable values in the same assembly valRefInThisAssembly g.compilingFslib v -let MustTakeAddressOfRecdField (rfref: RecdFieldRef) = +let MustTakeAddressOfRecdField (rf: RecdField) = // Static mutable fields must be private, hence we don't have to take their address - not rfref.RecdField.IsStatic && - rfref.RecdField.IsMutable + not rf.IsStatic && + rf.IsMutable -let CanTakeAddressOfRecdField g (rfref: RecdFieldRef) mut tinst = +let MustTakeAddressOfRecdFieldRef (rfref: RecdFieldRef) = MustTakeAddressOfRecdField rfref.RecdField + +let CanTakeAddressOfRecdFieldRef g (rfref: RecdFieldRef) mut tinst = mut <> DefinitelyMutates && // We only do this if the field is defined in this assembly because we can't take adddresses across assemblies for immutable fields entityRefInThisAssembly g.compilingFslib rfref.TyconRef && isRecdOrStuctTyImmutable g (actualTyOfRecdFieldRef rfref tinst) +let CanTakeAddressOfUnionFieldRef g (uref: UnionCaseRef) mut tinst cidx = + mut <> DefinitelyMutates && + // We only do this if the field is defined in this assembly because we can't take adddresses across assemblies for immutable fields + entityRefInThisAssembly g.compilingFslib uref.TyconRef && + isRecdOrStuctTyImmutable g (actualTyOfUnionFieldRef uref cidx tinst) + -let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = - if not mustTakeAddress then (fun x -> x),e else +let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = + if not mustTakeAddress then None,e else match e with // LVALUE: "x" where "x" is byref | Expr.Op (TOp.LValueOp (LByrefGet, v), _,[], m) -> - (fun x -> x), exprForValRef m v + None, exprForValRef m v // LVALUE: "x" where "x" is mutable local, mutable intra-assembly module/static binding, or operation doesn't mutate // Note: we can always take the address of mutable values | Expr.Val(v, _,m) when MustTakeAddressOfVal g v || CanTakeAddressOfImmutableVal g v mut -> - (fun x -> x), mkValAddr m v - // LVALUE: "x" where "e.x" is mutable record field. "e" may be an lvalue - | Expr.Op (TOp.ValFieldGet rfref, tinst,[e],m) when MustTakeAddressOfRecdField rfref || CanTakeAddressOfRecdField g rfref mut tinst -> + None, mkValAddr m v + // LVALUE: "x" where "e.x" is record field. + | Expr.Op (TOp.ValFieldGet rfref, tinst,[e],m) when MustTakeAddressOfRecdFieldRef rfref || CanTakeAddressOfRecdFieldRef g rfref mut tinst -> let exprty = tyOfExpr g e - let wrap,expra = mkExprAddrOfExpr g (isStructTy g exprty) false mut e None m + let wrap,expra = mkExprAddrOfExprAux g (isStructTy g exprty) false mut e None m wrap, mkRecdFieldGetAddrViaExprAddr(expra,rfref,tinst,m) + // LVALUE: "x" where "e.x" is union field + | Expr.Op (TOp.UnionCaseFieldGet (uref,cidx), tinst,[e],m) when MustTakeAddressOfRecdField (uref.FieldByIndex(cidx)) || CanTakeAddressOfUnionFieldRef g uref mut tinst cidx -> + let exprty = tyOfExpr g e + let wrap,expra = mkExprAddrOfExprAux g (isStructTy g exprty) false mut e None m + wrap, mkUnionCaseFieldGetAddrProvenViaExprAddr(expra,uref,tinst,cidx,m) // LVALUE: "x" where "e.x" is a .NET static field. | Expr.Op (TOp.ILAsm ([IL.I_ldsfld(_vol,fspec)],[ty2]), tinst,[],m) -> - (fun x -> x),Expr.Op (TOp.ILAsm ([IL.I_ldsflda(fspec)],[mkByrefTy g ty2]), tinst,[],m) + None,Expr.Op (TOp.ILAsm ([IL.I_ldsflda(fspec)],[mkByrefTy g ty2]), tinst,[],m) // LVALUE: "x" where "e.x" is a .NET instance field. "e" may be an lvalue | Expr.Op (TOp.ILAsm ([IL.I_ldfld(_align,_vol,fspec)],[ty2]), tinst,[e],m) -> let exprty = tyOfExpr g e - let wrap,expra = mkExprAddrOfExpr g (isStructTy g exprty) false mut e None m + let wrap,expra = mkExprAddrOfExprAux g (isStructTy g exprty) false mut e None m wrap,Expr.Op (TOp.ILAsm ([IL.I_ldflda(fspec)],[mkByrefTy g ty2]), tinst,[expra],m) // LVALUE: "x" where "x" is mutable static field. - | Expr.Op (TOp.ValFieldGet rfref, tinst,[],m) when MustTakeAddressOfRecdField rfref || CanTakeAddressOfRecdField g rfref mut tinst -> - (fun x -> x), mkStaticRecdFieldGetAddr(rfref,tinst,m) + | Expr.Op (TOp.ValFieldGet rfref, tinst,[],m) when MustTakeAddressOfRecdFieldRef rfref || CanTakeAddressOfRecdFieldRef g rfref mut tinst -> + None, mkStaticRecdFieldGetAddr(rfref,tinst,m) // LVALUE: "e.[n]" where e is an array of structs | Expr.App(Expr.Val(vf,_,_),_,[elemTy],[aexpr;nexpr],_) @@ -5423,7 +5458,7 @@ let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut match addrExprVal with | Some(vf) -> valRefEq g vf g.addrof2_vref | _ -> false - (fun x -> x), Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],[aexpr;nexpr],m) + None, Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],[aexpr;nexpr],m) // LVALUE: "e.[n1,n2]", "e.[n1,n2,n3]", "e.[n1,n2,n3,n4]" where e is an array of structs | Expr.App(Expr.Val(vf,_,_),_,[elemTy],(aexpr::args),_) @@ -5436,7 +5471,7 @@ let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut | Some(vf) -> valRefEq g vf g.addrof2_vref | _ -> false - (fun x -> x), Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],(aexpr::args),m) + None, Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],(aexpr::args),m) // Give a nice error message for DefinitelyMutates on immutable values, or mutable values in other assemblies | Expr.Val(v, _,m) when mut = DefinitelyMutates @@ -5457,15 +5492,24 @@ let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut | PossiblyMutates -> warning(DefensiveCopyWarning(FSComp.SR.tastValueHasBeenCopied(),m)); let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" ty - (fun rest -> mkCompGenLet m tmp e rest), (mkValAddr m (mkLocalValRef tmp)) + Some (tmp,e), (mkValAddr m (mkLocalValRef tmp)) + +let mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = + let optBind, addre = mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m + match optBind with + | None -> (fun x -> x), addre + | Some (tmp,rval) -> (fun x -> mkCompGenLet m tmp rval x), addre let mkRecdFieldGet g (e,fref:RecdFieldRef,tinst,m) = + assert (not (isByrefTy g (tyOfExpr g e))) let wrap,e' = mkExprAddrOfExpr g fref.Tycon.IsStructOrEnumTycon false NeverMutates e None m wrap (mkRecdFieldGetViaExprAddr(e',fref,tinst,m)) -let mkRecdFieldSet g (e,fref:RecdFieldRef,tinst,e2,m) = - let wrap,e' = mkExprAddrOfExpr g fref.Tycon.IsStructOrEnumTycon false DefinitelyMutates e None m - wrap (mkRecdFieldSetViaExprAddr(e',fref,tinst,e2,m)) +let mkUnionCaseFieldGetUnproven g (e,cref:UnionCaseRef,tinst,j,m) = + assert (not (isByrefTy g (tyOfExpr g e))) + let wrap,e' = mkExprAddrOfExpr g cref.Tycon.IsStructOrEnumTycon false NeverMutates e None m + wrap (mkUnionCaseFieldGetUnprovenViaExprAddr (e',cref,tinst,j,m)) + let mkArray (argty, args, m) = Expr.Op(TOp.Array, [argty],args,m) @@ -5505,12 +5549,13 @@ let rec IterateRecursiveFixups g (selfv : Val option) rvs ((access : Expr),set) | Expr.Op (TOp.UnionCase (c),tinst,args,m) -> args |> List.iteri (fun n -> IterateRecursiveFixups g None rvs - (mkUnionCaseFieldGetUnproven(access,c,tinst,n,m), + (mkUnionCaseFieldGetUnprovenViaExprAddr (access,c,tinst,n,m), (fun e -> // NICE: it would be better to do this check in the type checker let tcref = c.TyconRef - errorR(Error(FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType(tcref.LogicalName),m)); - mkUnionCaseFieldSet(access,c,tinst,n,e,m)))) + if not (c.FieldByIndex(n)).IsMutable && not (entityRefInThisAssembly g.compilingFslib tcref) then + errorR(Error(FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType(tcref.LogicalName),m)); + mkUnionCaseFieldSet (access,c,tinst,n,e,m)))) | Expr.Op (TOp.Recd (_,tcref),tinst,args,m) -> (tcref.TrueInstanceFieldsAsRefList, args) ||> List.iter2 (fun fref arg -> @@ -5521,7 +5566,7 @@ let rec IterateRecursiveFixups g (selfv : Val option) rvs ((access : Expr),set) // NICE: it would be better to do this check in the type checker if not fspec.IsMutable && not (entityRefInThisAssembly g.compilingFslib tcref) then errorR(Error(FSComp.SR.tastRecursiveValuesMayNotBeAssignedToNonMutableField(fspec.rfield_id.idText, tcref.LogicalName),m)); - mkRecdFieldSet g (access,fref,tinst,e,m))) arg ) + mkRecdFieldSetViaExprAddr (access,fref,tinst,e,m))) arg ) | Expr.Val _ | Expr.Lambda _ | Expr.Obj _ @@ -5850,8 +5895,8 @@ let mkRecordExpr g (lnk,tcref,tinst,rfrefs:RecdFieldRef list,args,m) = //------------------------------------------------------------------------- let mkRefCell g m ty e = mkRecordExpr g (RecdExpr,g.refcell_tcr_canon,[ty],[mkRefCellContentsRef g],[e],m) -let mkRefCellGet g m ty e = mkRecdFieldGet g (e,mkRefCellContentsRef g,[ty],m) -let mkRefCellSet g m ty e1 e2 = mkRecdFieldSet g (e1,mkRefCellContentsRef g,[ty],e2,m) +let mkRefCellGet g m ty e = mkRecdFieldGetViaExprAddr (e,mkRefCellContentsRef g,[ty],m) +let mkRefCellSet g m ty e1 e2 = mkRecdFieldSetViaExprAddr (e1,mkRefCellContentsRef g,[ty],e2,m) let mkNil g m ty = mkUnionCaseExpr (g.nil_ucref,[ty],[],m) let mkCons g ty h t = mkUnionCaseExpr (g.cons_ucref,[ty],[h;t],unionRanges h.Range t.Range) @@ -7843,8 +7888,8 @@ let DetectAndOptimizeForExpression g option expr = let elemTy = destListTy g enumerableTy let guardExpr = mkNonNullTest g m nextExpr - let headOrDefaultExpr = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexHead,m) - let tailOrNullExpr = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexTail,mBody) + let headOrDefaultExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr,g.cons_ucref,[elemTy],IndexHead,m) + let tailOrNullExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr,g.cons_ucref,[elemTy],IndexTail,mBody) let bodyExpr = mkCompGenLet m elemVar headOrDefaultExpr (mkCompGenSequential mBody diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 912c72872db6..651c927bc040 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -188,12 +188,35 @@ val mkStaticRecdFieldGet : RecdFieldRef * TypeInst val mkStaticRecdFieldSet : RecdFieldRef * TypeInst * Expr * range -> Expr val mkStaticRecdFieldGetAddr : RecdFieldRef * TypeInst * range -> Expr val mkRecdFieldSetViaExprAddr : Expr * RecdFieldRef * TypeInst * Expr * range -> Expr -val mkUnionCaseTagGet : Expr * TyconRef * TypeInst * range -> Expr +val mkUnionCaseTagGetViaExprAddr : Expr * TyconRef * TypeInst * range -> Expr + +/// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) val mkUnionCaseProof : Expr * UnionCaseRef * TypeInst * range -> Expr -val mkUnionCaseFieldGetProven : Expr * UnionCaseRef * TypeInst * int * range -> Expr -val mkUnionCaseFieldGetUnproven : Expr * UnionCaseRef * TypeInst * int * range -> Expr -val mkExnCaseFieldGet : Expr * TyconRef * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldGet' expression for something we've already determined to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +val mkUnionCaseFieldGetProvenViaExprAddr : Expr * UnionCaseRef * TypeInst * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +val mkUnionCaseFieldGetAddrProvenViaExprAddr : Expr * UnionCaseRef * TypeInst * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +val mkUnionCaseFieldGetUnprovenViaExprAddr : Expr * UnionCaseRef * TypeInst * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldSet' expression. For ref-unions, the input expression has 'TType_ucase', which is +/// an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. val mkUnionCaseFieldSet : Expr * UnionCaseRef * TypeInst * int * Expr * range -> Expr + +/// Like mkUnionCaseFieldGetUnprovenViaExprAddr, but for struct-unions, the input should be a copy of the expression. +val mkUnionCaseFieldGetUnproven : TcGlobals -> Expr * UnionCaseRef * TypeInst * int * range -> Expr + +val mkExnCaseFieldGet : Expr * TyconRef * int * range -> Expr val mkExnCaseFieldSet : Expr * TyconRef * int * Expr * range -> Expr //------------------------------------------------------------------------- @@ -217,6 +240,7 @@ val mkGetTupleItemN : TcGlobals -> range -> int -> ILType -> Expr -> TType -> Ex exception DefensiveCopyWarning of string * range type Mutates = DefinitelyMutates | PossiblyMutates | NeverMutates +val mkExprAddrOfExprAux : TcGlobals -> bool -> bool -> Mutates -> Expr -> ValRef option -> range -> (Val * Expr) option * Expr val mkExprAddrOfExpr : TcGlobals -> bool -> bool -> Mutates -> Expr -> ValRef option -> range -> (Expr -> Expr) * Expr //------------------------------------------------------------------------- @@ -811,7 +835,6 @@ val mkValAddr : range -> ValRef -> Expr //------------------------------------------------------------------------- val mkRecdFieldGet : TcGlobals -> Expr * RecdFieldRef * TypeInst * range -> Expr -val mkRecdFieldSet : TcGlobals -> Expr * RecdFieldRef * TypeInst * Expr * range -> Expr //------------------------------------------------------------------------- // Get the targets used in a decision graph (for reporting warnings) diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 2b68fbb7c57b..cf37fbfc1937 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -2315,6 +2315,7 @@ and p_op x st = | TOp.ValFieldGetAddr (a) -> p_byte 25 st; p_rfref a st | TOp.UInt16s arr -> p_byte 26 st; p_array p_uint16 arr st | TOp.Reraise -> p_byte 27 st + | TOp.UnionCaseFieldGetAddr (a,b) -> p_byte 28 st; p_tup2 p_ucref p_int (a,b) st | TOp.Goto _ | TOp.Label _ | TOp.Return -> failwith "unexpected backend construct in pickled TAST" #endif @@ -2376,6 +2377,9 @@ and u_op st = TOp.ValFieldGetAddr a | 26 -> TOp.UInt16s (u_array u_uint16 st) | 27 -> TOp.Reraise + | 28 -> let a = u_ucref st + let b = u_int st + TOp.UnionCaseFieldGetAddr (a,b) | _ -> ufailwith st "u_op" #if INCLUDE_METADATA_WRITER diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 5df8b030df18..f9957bc53cfa 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2988,7 +2988,8 @@ let BuildRecdFieldSet g m objExpr (rfinfo:RecdFieldInfo) argExpr = let tgty = rfinfo.EnclosingType let valu = isStructTy g tgty let objExpr = if valu then objExpr else mkCoerceExpr(objExpr,tgty,m,tyOfExpr g objExpr) - mkRecdFieldSet g (objExpr,rfinfo.RecdFieldRef,rfinfo.TypeInst,argExpr,m) + let wrap,objExpr = mkExprAddrOfExpr g valu false DefinitelyMutates objExpr None m + wrap (mkRecdFieldSetViaExprAddr (objExpr,rfinfo.RecdFieldRef,rfinfo.TypeInst,argExpr,m) ) //------------------------------------------------------------------------- @@ -3622,7 +3623,7 @@ let CheckAndRewriteObjectCtor g env (ctorLambaExpr:Expr) = let thisTy = tyOfExpr g recdExpr let thisExpr = mkGetArg0 m thisTy let thisTyInst = argsOfAppTy g thisTy - let setExpr = mkRecdFieldSet g (thisExpr, rfref, thisTyInst, mkOne g m, m) + let setExpr = mkRecdFieldSetViaExprAddr (thisExpr, rfref, thisTyInst, mkOne g m, m) Expr.Sequential(recdExpr,setExpr,ThenDoSeq,SuppressSequencePointOnExprOfSequential,m) recdExpr @@ -5657,7 +5658,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.LibraryOnlyUnionCaseFieldGet (e1,c,n,m) -> let e1',ty1,tpenv = TcExprOfUnknownType cenv env tpenv e1 let mkf,ty2 = TcUnionCaseOrExnField cenv env ty1 m c n - ((fun (a,b) n -> mkUnionCaseFieldGetUnproven(e1',a,b,n,m)), + ((fun (a,b) n -> mkUnionCaseFieldGetUnproven cenv.g (e1',a,b,n,m)), (fun a n -> mkExnCaseFieldGet(e1',a,n,m))) UnifyTypes cenv env m overallTy ty2 mkf n,tpenv @@ -5943,18 +5944,19 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = (fname,fieldExpr),tpenv) // Add rebindings for unbound field when an "old value" is available - let oldFldsList = + // Effect order: mutable fields may get modified by other bindings... + let oldFldsList, wrap = match optOrigExpr with - | None -> [] - | Some (_,_,oldve') -> - // When we have an "old" value, append bindings for the unbound fields. - // Effect order - mutable fields may get modified by other bindings... - let fieldNameUnbound nom = List.forall (fun (name,_) -> name <> nom) fldsList - fspecs - |> List.choose (fun rfld -> + | None -> [], id + | Some (_,_,oldve) -> + let wrap,oldveaddr = mkExprAddrOfExpr cenv.g tycon.IsStructOrEnumTycon false NeverMutates oldve None m + let fieldNameUnbound nom = List.forall (fun (name,_) -> name <> nom) fldsList + let flds = + fspecs |> List.choose (fun rfld -> if fieldNameUnbound rfld.Name && not rfld.IsZeroInit - then Some(rfld.Name, mkRecdFieldGet cenv.g (oldve',tcref.MakeNestedRecdFieldRef rfld,tinst,m)) + then Some(rfld.Name, mkRecdFieldGetViaExprAddr (oldveaddr,tcref.MakeNestedRecdFieldRef rfld,tinst,m)) else None) + flds, wrap let fldsList = fldsList @ oldFldsList @@ -5987,7 +5989,7 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = let args = List.map snd fldsList - let expr = mkRecordExpr cenv.g (GetRecdInfo env, tcref, tinst, rfrefs, args, m) + let expr = wrap (mkRecordExpr cenv.g (GetRecdInfo env, tcref, tinst, rfrefs, args, m)) let expr = match optOrigExpr with @@ -5995,10 +5997,10 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = // '{ recd fields }'. // expr - | Some (old',oldv',_) -> + | Some (old,oldv,_) -> // '{ recd with fields }'. // Assign the first object to a tmp and then construct - mkCompGenLet m oldv' old' expr + mkCompGenLet m oldv old expr expr, tpenv @@ -6437,13 +6439,13 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr let optOrigExpr,tpenv = match optOrigExpr with | None -> None, tpenv - | Some (e, _) -> + | Some (origExpr, _) -> match inherits with | Some (_,_,mInherits, _, _) -> error(Error(FSComp.SR.tcInvalidRecordConstruction(),mInherits)) | None -> - let e',tpenv = TcExpr cenv overallTy env tpenv e - let v',ve' = mkCompGenLocal mWholeExpr "inputRecord" overallTy - Some (e',v',ve'), tpenv + let olde,tpenv = TcExpr cenv overallTy env tpenv origExpr + let oldv,oldve = mkCompGenLocal mWholeExpr "inputRecord" overallTy + Some (olde,oldv,oldve), tpenv let fldsList = let flds = @@ -9272,7 +9274,9 @@ and TcMethodApplication match assignedArg.CalledArg.OptArgInfo with | CallerSide _ -> if isOptCallerArg then - mkUnionCaseFieldGetUnproven(expr,mkSomeCase cenv.g,[destOptionTy cenv.g callerArgTy],0,m) + // STRUCT OPTIONS: if we allow struct options as optional arguments then we should take + // the address correctly. + mkUnionCaseFieldGetUnprovenViaExprAddr (expr,mkSomeCase cenv.g,[destOptionTy cenv.g callerArgTy],0,m) else expr | CalleeSide -> @@ -10915,7 +10919,7 @@ and MakeCheckSafeInitField g tinst thisValOpt rfref reqExpr (expr:Expr) = | None -> mkStaticRecdFieldGet (rfref, tinst, m) | Some thisVar -> // This is an instance method, it must have a 'this' var - mkRecdFieldGet g (exprForVal m thisVar, rfref, tinst, m) + mkRecdFieldGetViaExprAddr (exprForVal m thisVar, rfref, tinst, m) let failureExpr = match thisValOpt with None -> mkCallFailStaticInit g m | Some _ -> mkCallFailInit g m mkCompGenSequential m (mkIfThen g m (mkILAsmClt g m availExpr reqExpr) failureExpr) expr @@ -12050,7 +12054,7 @@ module IncrClassChecking = begin let binders = [ match ctorInfo.InstanceCtorSafeInitInfo with | SafeInitField (rfref, _) -> - let setExpr = mkRecdFieldSet cenv.g (exprForVal m thisVal, rfref, thisTyInst, mkOne cenv.g m, m) + let setExpr = mkRecdFieldSetViaExprAddr (exprForVal m thisVal, rfref, thisTyInst, mkOne cenv.g m, m) let setExpr = reps.FixupIncrClassExprPassC (Some(thisVal)) safeStaticInitInfo thisTyInst setExpr let binder = (fun e -> mkSequential SequencePointsAtSeq setExpr.Range setExpr e) let isPriorToSuperInit = false @@ -13567,7 +13571,7 @@ module EstablishTypeDefinitionCores = begin if hasClassAttr && not (match k with TyconClass -> true | _ -> false) || hasMeasureAttr && not (match k with TyconClass | TyconAbbrev | TyconHiddenRepr -> true | _ -> false) || hasInterfaceAttr && not (match k with TyconInterface -> true | _ -> false) || - hasStructAttr && not (match k with TyconStruct | TyconRecord -> true | _ -> false) then + hasStructAttr && not (match k with TyconStruct | TyconRecord | TyconUnion -> true | _ -> false) then error(Error(FSComp.SR.tcKindOfTypeSpecifiedDoesNotMatchDefinition(),m)) k @@ -13594,13 +13598,14 @@ module EstablishTypeDefinitionCores = begin [ match synTyconRepr with | SynTypeDefnSimpleRepr.None _ -> () | SynTypeDefnSimpleRepr.Union (_,unionCases,_) -> + for (UnionCase (_,_,args,_,_,m)) in unionCases do - match args with - | UnionCaseFields flds -> + match args with + | UnionCaseFields flds -> for (Field(_,_,_,ty,_,_,_,m)) in flds do let ty',_ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty yield (ty',m) - | UnionCaseFullType (ty,arity) -> + | UnionCaseFullType (ty,arity) -> let ty',_ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty let argtysl,_ = GetTopTauTypeInFSharpForm cenv.g (arity |> TranslateTopValSynInfo m (TcAttributes cenv env) |> TranslatePartialArity []).ArgInfos ty' m if argtysl.Length > 1 then @@ -13638,7 +13643,7 @@ module EstablishTypeDefinitionCores = begin /// but /// - we don't yet 'properly' establish constraints on type parameters let private TcTyconDefnCore_Phase0_BuildInitialTycon cenv env parent (TyconDefnCoreIndexed(synTyconInfo,synTyconRepr,_,preEstablishedHasDefaultCtor,hasSelfReferentialCtor,_)) = - let (ComponentInfo(synAttrs,synTypars, _,id,doc,preferPostfix, vis,_)) = synTyconInfo + let (ComponentInfo(_,synTypars, _,id,doc,preferPostfix, vis,_)) = synTyconInfo let checkedTypars = TcTyparDecls cenv env synTypars id |> List.iter (CheckNamespaceModuleOrTypeName cenv.g) let id = ComputeTyconName (id, (match synTyconRepr with SynTypeDefnSimpleRepr.TypeAbbrev _ -> false | _ -> true), checkedTypars) @@ -13667,15 +13672,7 @@ module EstablishTypeDefinitionCores = begin // If we supported nested types and modules then additions would be needed here let lmtyp = notlazy (NewEmptyModuleOrNamespaceType ModuleOrType) - let isStructRecordType = - match synTyconRepr with - | SynTypeDefnSimpleRepr.Record _ -> - let attrs = TcAttributes cenv env AttributeTargets.TyconDecl synAttrs - HasFSharpAttribute cenv.g cenv.g.attrib_StructAttribute attrs - | _ -> - false - - NewTycon(cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars, doc.ToXmlDoc(), preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordType, lmtyp) + NewTycon(cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars, doc.ToXmlDoc(), preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmtyp) //------------------------------------------------------------------------- /// Establishing type definitions: early phase: work out the basic kind of the type definition @@ -13697,6 +13694,16 @@ module EstablishTypeDefinitionCores = begin let attrs = TcAttributes cenv envinner AttributeTargets.TyconDecl synAttrs let hasMeasureAttr = HasFSharpAttribute cenv.g cenv.g.attrib_MeasureAttribute attrs + let isStructRecordOrUnionType = + match synTyconRepr with + | SynTypeDefnSimpleRepr.Record _ + | SynTypeDefnSimpleRepr.Union _ -> + HasFSharpAttribute cenv.g cenv.g.attrib_StructAttribute attrs + | _ -> + false + + tycon.SetIsStructRecordOrUnion isStructRecordOrUnionType + // Set the compiled name, if any tycon.Data.entity_compiled_name <- TryFindFSharpStringAttribute cenv.g cenv.g.attrib_CompiledNameAttribute attrs @@ -14088,10 +14095,10 @@ module EstablishTypeDefinitionCores = begin match synTyconRepr with | SynTypeDefnSimpleRepr.None _ -> None | SynTypeDefnSimpleRepr.TypeAbbrev _ -> None - | SynTypeDefnSimpleRepr.Union _ -> None | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly _ -> None + | SynTypeDefnSimpleRepr.Union _ | SynTypeDefnSimpleRepr.Record _ -> - if tycon.IsStructRecordTycon then Some(cenv.g.system_Value_typ) + if tycon.IsStructRecordOrUnionTycon then Some(cenv.g.system_Value_typ) else None | SynTypeDefnSimpleRepr.General (kind,_,slotsigs,fields,isConcrete,_,_,_) -> let kind = InferTyconKind cenv.g (kind,attrs,slotsigs,fields,inSig,isConcrete,m) @@ -14286,6 +14293,10 @@ module EstablishTypeDefinitionCores = begin noAllowNullLiteralAttributeCheck() structLayoutAttributeCheck(false) let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy tpenv unionCases + + if tycon.IsStructRecordOrUnionTycon && unionCases.Length > 1 then + errorR(Error(FSComp.SR.tcStructUnionMultiCase(),m)) + writeFakeUnionCtorsToSink unionCases MakeUnionRepr unionCases, None, NoSafeInitInfo @@ -14622,11 +14633,18 @@ module EstablishTypeDefinitionCores = begin else // Only collect once from each type instance. let doneTypes = ty :: doneTypes - let fspecs = structTycon.AllFieldsAsList |> List.filter (fun fspec -> includeStaticFields || not fspec.IsStatic) + let fspecs = + if structTycon.IsUnionTycon then + [ for uc in structTycon.UnionCasesArray do + for c in uc.FieldTable.AllFieldsAsList do + yield c] + else + structTycon.AllFieldsAsList + let fspecs = fspecs |> List.filter (fun fspec -> includeStaticFields || not fspec.IsStatic) let doneTypes,acc = List.foldBack (accStructField structTycon tinst) fspecs (doneTypes,acc) doneTypes,acc and accStructInstanceFields ty structTycon tinst (doneTypes,acc) = accStructFields false ty structTycon tinst (doneTypes,acc) - and accStructAllFields ty structTycon tinst (doneTypes,acc) = accStructFields true ty structTycon tinst (doneTypes,acc) + and accStructAllFields ty (structTycon: Tycon) tinst (doneTypes,acc) = accStructFields true ty structTycon tinst (doneTypes,acc) let acc = [] let acc = diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 93d8287315d9..76e45b9b8157 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -87,7 +87,7 @@ let GetSuperTypeOfType g amap m typ = Some g.obj_ty elif isTupleStructTy g typ then Some g.obj_ty - elif isRecdTy g typ then + elif isRecdTy g typ || isUnionTy g typ then Some g.obj_ty else None diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 962181713ab5..c3154c8eb7b7 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -350,12 +350,12 @@ type TyparFlags(flags:int32) = [] type EntityFlags(flags:int64) = - new (usesPrefixDisplay, isModuleOrNamespace, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordType) = + new (usesPrefixDisplay, isModuleOrNamespace, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordOrUnionType) = EntityFlags((if isModuleOrNamespace then 0b00000000001L else 0L) ||| (if usesPrefixDisplay then 0b00000000010L else 0L) ||| (if preEstablishedHasDefaultCtor then 0b00000000100L else 0L) ||| (if hasSelfReferentialCtor then 0b00000001000L else 0L) ||| - (if isStructRecordType then 0b00000100000L else 0L)) + (if isStructRecordOrUnionType then 0b00000100000L else 0L)) member x.IsModuleOrNamespace = (flags &&& 0b00000000001L) <> 0x0L member x.IsPrefixDisplay = (flags &&& 0b00000000010L) <> 0x0L @@ -370,7 +370,7 @@ type EntityFlags(flags:int64) = member x.HasSelfReferentialConstructor = (flags &&& 0b00000001000L) <> 0x0L /// This bit represents a F# record that is a value type, or a struct record. - member x.IsStructRecordType = (flags &&& 0b00000100000L) <> 0x0L + member x.IsStructRecordOrUnionType = (flags &&& 0b00000100000L) <> 0x0L /// This bit is reserved for us in the pickle format, see pickle.fs, it's bing listed here to stop it ever being used for anything else static member ReservedBitForPickleFormatTyconReprFlag = 0b00000010000L @@ -776,7 +776,7 @@ type Entity = member x.IsRecordTycon = match x.TypeReprInfo with | TRecdRepr _ -> true | _ -> false /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition that is a value type. - member x.IsStructRecordTycon = match x.TypeReprInfo with | TRecdRepr _ -> x.Data.entity_flags.IsStructRecordType | _ -> false + member x.IsStructRecordOrUnionTycon = match x.TypeReprInfo with TRecdRepr _ | TUnionRepr _ -> x.Data.entity_flags.IsStructRecordOrUnionType | _ -> false /// Indicates if this is an F# type definition whose r.h.s. is known to be some kind of F# object model definition member x.IsFSharpObjectModelTycon = match x.TypeReprInfo with | TFSharpObjectRepr _ -> true | _ -> false @@ -822,7 +822,8 @@ type Entity = /// Indicates if this is an F#-defined struct or enum type definition , i.e. a value type definition member x.IsFSharpStructOrEnumTycon = match x.TypeReprInfo with - | TRecdRepr _ -> x.IsStructRecordTycon + | TRecdRepr _ -> x.IsStructRecordOrUnionTycon + | TUnionRepr _ -> x.IsStructRecordOrUnionTycon | TFSharpObjectRepr info -> match info.fsobjmodel_kind with | TTyconClass | TTyconInterface | TTyconDelegate _ -> false @@ -963,6 +964,9 @@ type Entity = /// Set the custom attributes on an F# type definition. member x.SetAttribs attribs = x.Data.entity_attribs <- attribs + /// Sets the structness of a record or union type definition + member x.SetIsStructRecordOrUnion b = let x = x.Data in let flags = x.entity_flags in x.entity_flags <- EntityFlags(flags.IsPrefixDisplay, flags.IsModuleOrNamespace, flags.PreEstablishedHasDefaultConstructor, flags.HasSelfReferentialConstructor, b) + and @@ -1731,7 +1735,7 @@ and Construct = entity_kind=kind entity_range=m entity_other_range=None - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordType=false) + entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) entity_attribs=[] // fetched on demand via est.fs API entity_typars= LazyWithContext.NotLazy [] entity_tycon_abbrev = None @@ -1760,7 +1764,7 @@ and Construct = entity_stamp=stamp entity_kind=TyparKind.Type entity_modul_contents = mtype - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false,isStructRecordType=false) + entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false,isStructRecordOrUnionType=false) entity_typars=LazyWithContext.NotLazy [] entity_tycon_abbrev = None entity_tycon_repr = TNoRepr @@ -3574,15 +3578,16 @@ and /// TDSwitch(input, cases, default, range) /// /// Indicates a decision point in a decision tree. - /// input -- the expression being tested - /// cases -- the list of tests and their subsequent decision trees - /// default -- the default decision tree, if any + /// input -- The expression being tested. If switching over a struct union this + /// must be the address of the expression being tested. + /// cases -- The list of tests and their subsequent decision trees + /// default -- The default decision tree, if any /// range -- (precise documentation needed) | TDSwitch of Expr * DecisionTreeCase list * DecisionTree option * range /// TDSuccess(results, targets) /// - /// Indicates the decision tree has terminated with success, calling the given target with the given parameters. + /// Indicates the decision tree has terminated with success, transferring control to the given target with the given parameters. /// results -- the expressions to be bound to the variables at the target /// target -- the target number for the continuation | TDSuccess of FlatExprs * int @@ -3826,6 +3831,8 @@ and | UnionCaseProof of UnionCaseRef /// An operation representing a field-get from a union value, where that value has been proven to be of the corresponding union case. | UnionCaseFieldGet of UnionCaseRef * int + /// An operation representing a field-get from a union value, where that value has been proven to be of the corresponding union case. + | UnionCaseFieldGetAddr of UnionCaseRef * int /// An operation representing a field-get from a union value. The value is not assumed to have been proven to be of the corresponding union case. | UnionCaseFieldSet of UnionCaseRef * int /// An operation representing a field-get from an F# exception value. @@ -4568,7 +4575,7 @@ let NewExn cpath (id:Ident) access repr attribs doc = entity_typars=LazyWithContext.NotLazy [] entity_tycon_abbrev = None entity_tycon_repr = TNoRepr - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordType=false) + entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) entity_il_repr_cache= newCache() } let NewRecdField stat konst id ty isMutable isVolatile pattribs fattribs docOption access secret = @@ -4587,7 +4594,7 @@ let NewRecdField stat konst id ty isMutable isVolatile pattribs fattribs docOpt rfield_other_range = None } -let NewTycon (cpath, nm, m, access, reprAccess, kind, typars, docOption, usesPrefixDisplay, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordType, mtyp) = +let NewTycon (cpath, nm, m, access, reprAccess, kind, typars, docOption, usesPrefixDisplay, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, mtyp) = let stamp = newStamp() Tycon.New "tycon" { entity_stamp=stamp @@ -4596,7 +4603,7 @@ let NewTycon (cpath, nm, m, access, reprAccess, kind, typars, docOption, usesPre entity_kind=kind entity_range=m entity_other_range=None - entity_flags=EntityFlags(usesPrefixDisplay=usesPrefixDisplay, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=preEstablishedHasDefaultCtor, hasSelfReferentialCtor=hasSelfReferentialCtor, isStructRecordType=isStructRecordType) + entity_flags=EntityFlags(usesPrefixDisplay=usesPrefixDisplay, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=preEstablishedHasDefaultCtor, hasSelfReferentialCtor=hasSelfReferentialCtor, isStructRecordOrUnionType=false) entity_attribs=[] // fixed up after entity_typars=typars entity_tycon_abbrev = None @@ -4617,7 +4624,7 @@ let NewILTycon nlpath (nm,m) tps (scoref:ILScopeRef, enc, tdef:ILTypeDef) mtyp = // NOTE: hasSelfReferentialCtor=false is an assumption about mscorlib let hasSelfReferentialCtor = tdef.IsClass && (not scoref.IsAssemblyRef && scoref.AssemblyRef.Name = "mscorlib") - let tycon = NewTycon(nlpath, nm, m, taccessPublic, taccessPublic, TyparKind.Type, tps, XmlDoc.Empty, true, false, hasSelfReferentialCtor, false, mtyp) + let tycon = NewTycon(nlpath, nm, m, taccessPublic, taccessPublic, TyparKind.Type, tps, XmlDoc.Empty, true, false, hasSelfReferentialCtor, mtyp) tycon.Data.entity_tycon_repr <- TILObjectRepr (scoref,enc,tdef) tycon.TypeContents.tcaug_closed <- true diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index fac033126f9f..c4cdfab06256 100644 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -39,8 +39,7 @@ type DiscriminationTechnique = // class (no subclasses), but an integer tag is stored to discriminate between the objects. | IntegerTag -// FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS looks like a useful representation -// optimization - it trades an extra integer tag in the root type +// A potentially useful additional representation trades an extra integer tag in the root type // for faster discrimination, and in the important single-non-nullary constructor case // // type Tree = Tip | Node of int * Tree * Tree @@ -60,14 +59,15 @@ type UnionReprDecisions<'Union,'Alt,'Type> nullPermitted:'Union->bool, isNullary:'Alt->bool, isList:'Union->bool, + isStruct:'Union->bool, nameOfAlt : 'Alt -> string, makeRootType: 'Union -> 'Type, makeNestedType: 'Union * string -> 'Type) = static let TaggingThresholdFixedConstant = 4 - member repr.OptimizeAllAlternativesToConstantFieldsInRootClass cu = - Array.forall isNullary (getAlternatives cu) + member repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu = + cu |> getAlternatives |> Array.forall isNullary member repr.DiscriminationTechnique cu = if isList cu then @@ -77,18 +77,15 @@ type UnionReprDecisions<'Union,'Alt,'Type> if alts.Length = 1 then SingleCase elif -#if FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS - nullPermitted cu then -#else + not (isStruct cu) && alts.Length < TaggingThresholdFixedConstant && - not (repr.OptimizeAllAlternativesToConstantFieldsInRootClass cu) then -#endif + not (repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu) then RuntimeTypes else IntegerTag // WARNING: this must match IsUnionTypeWithNullAsTrueValue in the F# compiler - member repr.OptimizeAlternativeToNull (cu,alt) = + member repr.RepresentAlternativeAsNull (cu,alt) = let alts = getAlternatives cu nullPermitted cu && (repr.DiscriminationTechnique cu = RuntimeTypes) && (* don't use null for tags, lists or single-case *) @@ -96,54 +93,52 @@ type UnionReprDecisions<'Union,'Alt,'Type> Array.exists (isNullary >> not) alts && isNullary alt (* is this the one? *) - member repr.OptimizingOneAlternativeToNull cu = + member repr.RepresentOneAlternativeAsNull cu = let alts = getAlternatives cu nullPermitted cu && - alts |> Array.existsOne (fun alt -> repr.OptimizeAlternativeToNull (cu,alt)) + alts |> Array.existsOne (fun alt -> repr.RepresentAlternativeAsNull (cu,alt)) - member repr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cu,alt) = + member repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cu,alt) = // Check all nullary constructors are being represented without using sub-classes let alts = getAlternatives cu + not (isStruct cu) && not (isNullary alt) && - (alts |> Array.forall (fun alt2 -> not (isNullary alt2) || repr.OptimizeAlternativeToNull (cu,alt2))) && + (alts |> Array.forall (fun alt2 -> not (isNullary alt2) || repr.RepresentAlternativeAsNull (cu,alt2))) && // Check this is the one and only non-nullary constructor Array.existsOne (isNullary >> not) alts -#if FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS - member repr.OptimizeSingleNonNullaryAlternativeToRootClassAndOtherAlternativesToTagged (cu,alt) = - let alts = getAlternatives cu - not (isNullary alt) && - alts.Length > 1 && - Array.existsOne (isNullary >> not) alts && - not (nullPermitted cu) -#endif - - member repr.OptimizeSingleNonNullaryAlternativeToRootClass (cu,alt) = + member repr.RepresentAlternativeAsFreshInstancesOfRootClass (cu,alt) = + // Flattening + isStruct cu || // Check all nullary constructors are being represented without using sub-classes (isList cu && nameOfAlt alt = ALT_NAME_CONS) || - repr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cu, alt) -#if FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS - repr.OptimizeSingleNonNullaryAlternativeToRootClassAndOtherAlternativesToTagged (cu,alt) -#endif + repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cu, alt) - member repr.OptimizeAlternativeToConstantFieldInTaggedRootClass (cu,alt) = + member repr.RepresentAlternativeAsConstantFieldInTaggedRootClass (cu,alt) = + not (isStruct cu) && isNullary alt && - not (repr.OptimizeAlternativeToNull (cu,alt)) && + not (repr.RepresentAlternativeAsNull (cu,alt)) && (repr.DiscriminationTechnique cu <> RuntimeTypes) + member repr.Flatten cu = + isStruct cu + member repr.OptimizeAlternativeToRootClass (cu,alt) = // The list type always collapses to the root class isList cu || - repr.OptimizeAllAlternativesToConstantFieldsInRootClass cu || - repr.OptimizeAlternativeToConstantFieldInTaggedRootClass (cu,alt) || - repr.OptimizeSingleNonNullaryAlternativeToRootClass(cu,alt) + // Structs are always flattened + repr.Flatten cu || + repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu || + repr.RepresentAlternativeAsConstantFieldInTaggedRootClass (cu,alt) || + repr.RepresentAlternativeAsFreshInstancesOfRootClass(cu,alt) member repr.MaintainPossiblyUniqueConstantFieldForAlternative(cu,alt) = - not (repr.OptimizeAlternativeToNull (cu,alt)) && + not (isStruct cu) && + not (repr.RepresentAlternativeAsNull (cu,alt)) && isNullary alt member repr.TypeForAlternative (cuspec,alt) = - if repr.OptimizeAlternativeToRootClass (cuspec,alt) || repr.OptimizeAlternativeToNull (cuspec,alt) then + if repr.OptimizeAlternativeToRootClass (cuspec,alt) || repr.RepresentAlternativeAsNull (cuspec,alt) then makeRootType cuspec else let altName = nameOfAlt alt @@ -153,7 +148,7 @@ type UnionReprDecisions<'Union,'Alt,'Type> let baseTyOfUnionSpec (cuspec : IlxUnionSpec) = - mkILBoxedTyRaw cuspec.TypeRef cuspec.GenericArgs + mkILNamedTyRaw cuspec.Boxity cuspec.TypeRef cuspec.GenericArgs let mkMakerName (cuspec: IlxUnionSpec) nm = match cuspec.HasHelpers with @@ -170,9 +165,10 @@ let cuspecRepr = (fun (cuspec:IlxUnionSpec) -> cuspec.IsNullPermitted), (fun (alt:IlxUnionAlternative) -> alt.IsNullary), (fun cuspec -> cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), + (fun cuspec -> cuspec.Boxity = ILBoxity.AsValue), (fun (alt:IlxUnionAlternative) -> alt.Name), - (fun cuspec -> mkILBoxedTyRaw cuspec.TypeRef cuspec.GenericArgs), - (fun (cuspec,nm) -> mkILBoxedTyRaw (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs)) + (fun cuspec -> cuspec.EnclosingType), + (fun (cuspec,nm) -> mkILNamedTyRaw cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs)) type NoTypesGeneratedViaThisReprDecider = NoTypesGeneratedViaThisReprDecider let cudefRepr = @@ -181,6 +177,7 @@ let cudefRepr = (fun (_td,cud) -> cud.cudNullPermitted), (fun (alt:IlxUnionAlternative) -> alt.IsNullary), (fun (_td,cud) -> cud.cudHasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), + (fun (td,_cud) -> match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false), (fun (alt:IlxUnionAlternative) -> alt.Name), (fun (_td,_cud) -> NoTypesGeneratedViaThisReprDecider), (fun ((_td,_cud),_nm) -> NoTypesGeneratedViaThisReprDecider)) @@ -198,7 +195,7 @@ let refToFieldInTy ty (nm, fldTy) = mkILFieldSpecInTy (ty, nm, fldTy) let formalTypeArgs (baseTy:ILType) = ILList.mapi (fun i _ -> mkILTyvarTy (uint16 i)) baseTy.GenericArgs let constFieldName nm = "_unique_" + nm let constFormalFieldTy (baseTy:ILType) = - ILType.Boxed (mkILTySpecRaw (baseTy.TypeRef, formalTypeArgs baseTy)) + mkILNamedTyRaw baseTy.Boxity baseTy.TypeRef (formalTypeArgs baseTy) let mkConstFieldSpecFromId (baseTy:ILType) constFieldId = refToFieldInTy baseTy constFieldId @@ -265,13 +262,22 @@ let mkLdData (avoidHelpers, cuspec, cidx, fidx) = else [ mkNormalCall (mkILNonGenericInstanceMethSpecInTy(altTy,"get_" + adjustFieldName cuspec.HasHelpers fieldDef.Name,[],fieldDef.Type)) ] +let mkLdDataAddr (avoidHelpers, cuspec, cidx, fidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAlt cuspec alt + let fieldDef = alt.FieldDef fidx + if avoidHelpers then + [ mkNormalLdflda (mkILFieldSpecInTy(altTy,fieldDef.LowerName, fieldDef.Type)) ] + else + failwith (sprintf "can't load address using helpers, for fieldDef %s" fieldDef.LowerName) + let mkGetTailOrNull avoidHelpers cuspec = mkLdData (avoidHelpers, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = let baseTy = baseTyOfUnionSpec cuspec - if cuspecRepr.OptimizingOneAlternativeToNull cuspec then + if cuspecRepr.RepresentOneAlternativeAsNull cuspec then mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [baseTy], mkTagFieldFormalType ilg cuspec)) else mkNormalCall (mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) @@ -289,32 +295,29 @@ let mkCeqThen after = let mkTagDiscriminate ilg cuspec _baseTy cidx = - mkGetTag ilg cuspec - @ [ mkLdcInt32 cidx - AI_ceq ] + mkGetTag ilg cuspec @ [ mkLdcInt32 cidx; AI_ceq ] let mkTagDiscriminateThen ilg cuspec cidx after = - mkGetTag ilg cuspec - @ [ mkLdcInt32 cidx ] - @ mkCeqThen after + mkGetTag ilg cuspec @ [ mkLdcInt32 cidx ] @ mkCeqThen after let convNewDataInstrInternal ilg cuspec cidx = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then [ AI_ldnull ] elif cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative (cuspec,alt) then let baseTy = baseTyOfUnionSpec cuspec [ I_ldsfld (Nonvolatile,mkConstFieldSpec altName baseTy) ] - elif cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClass (cuspec,alt) then + elif cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass (cuspec,alt) then let baseTy = baseTyOfUnionSpec cuspec let instrs, tagfields = match cuspecRepr.DiscriminationTechnique cuspec with | IntegerTag -> [ mkLdcInt32 cidx ], [mkTagFieldType ilg cuspec] | _ -> [], [] - instrs @ [ mkNormalNewobj(mkILCtorMethSpecForTy (baseTy,(Array.toList alt.FieldTypes @ tagfields))) ] + let ctorFieldTys = alt.FieldTypes |> Array.toList + instrs @ [ mkNormalNewobj(mkILCtorMethSpecForTy (baseTy,(ctorFieldTys @ tagfields))) ] else [ mkNormalNewobj(mkILCtorMethSpecForTy (altTy,Array.toList alt.FieldTypes)) ] @@ -334,7 +337,7 @@ let mkNewData ilg (cuspec, cidx) = | AllHelpers | SpecialFSharpListHelpers | SpecialFSharpOptionHelpers -> - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then [ AI_ldnull ] elif alt.IsNullary then [ mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) ] @@ -353,9 +356,9 @@ let mkIsData ilg (avoidHelpers, cuspec, cidx) = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then [ AI_ldnull; AI_ceq ] - elif cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cuspec,alt) then + elif cuspecRepr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cuspec,alt) then // in this case we can use a null test [ AI_ldnull; AI_cgt_un ] else @@ -377,7 +380,6 @@ type ICodeGen<'Mark> = abstract EmitInstr : ILInstr -> unit abstract EmitInstrs : ILInstr list -> unit -// TODO: this will be removed let genWith g : ILCode = let instrs = ResizeArray() let lab2pc = Dictionary() @@ -399,9 +401,9 @@ let mkBrIsNotData ilg (avoidHelpers, cuspec,cidx,tg) = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then [ I_brcmp (BI_brtrue,tg) ] - elif cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cuspec,alt) then + elif cuspecRepr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cuspec,alt) then // in this case we can use a null test [ I_brcmp (BI_brfalse,tg) ] else @@ -454,10 +456,10 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxU let alt = altOfUnionSpec cuspec cidx let internalLab = cg.GenerateDelayMark() let failLab = cg.GenerateDelayMark () - let cmpNull = cuspecRepr.OptimizeAlternativeToNull (cuspec, alt) + let cmpNull = cuspecRepr.RepresentAlternativeAsNull (cuspec, alt) let test = I_brcmp ((if cmpNull then BI_brtrue else BI_brfalse),cg.CodeLabel failLab) let testBlock = - if cmpNull || cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClass (cuspec,alt) then + if cmpNull || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass (cuspec,alt) then [ test ] else let altName = alt.Name @@ -479,9 +481,9 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxU let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxUnionSpec) = emitLdDataTagPrim ilg None cg (avoidHelpers,cuspec) -let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail,cuspec,cidx) = +let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail,avoidHelpers,cuspec,cidx) = let alt = altOfUnionSpec cuspec cidx - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then if canfail then let outlab = cg.GenerateDelayMark () let internal1 = cg.GenerateDelayMark () @@ -489,7 +491,22 @@ let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail,cuspec,cidx) = cg.SetMarkToHere internal1 cg.EmitInstrs [mkPrimaryAssemblyExnNewobj ilg "System.InvalidCastException"; I_throw ] cg.SetMarkToHere outlab - // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + else + // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + () + elif cuspecRepr.Flatten cuspec then + if canfail then + let outlab = cg.GenerateDelayMark () + let internal1 = cg.GenerateDelayMark () + cg.EmitInstrs [ AI_dup ] + emitLdDataTagPrim ilg None cg (avoidHelpers,cuspec) + cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp (BI_beq, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [mkPrimaryAssemblyExnNewobj ilg "System.InvalidCastException"; I_throw ] + cg.SetMarkToHere outlab + else + // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + () elif cuspecRepr.OptimizeAlternativeToRootClass (cuspec,alt) then () else @@ -510,11 +527,11 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = let altTy = tyForAlt cuspec alt let altName = alt.Name let failLab = cg.GenerateDelayMark () - let cmpNull = cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) + let cmpNull = cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) cg.EmitInstr (mkLdloc locn) let testInstr = I_brcmp ((if cmpNull then BI_brfalse else BI_brtrue),tg) - if cmpNull || cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClass (cuspec,alt) then + if cmpNull || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass (cuspec,alt) then cg.EmitInstr testInstr else cg.EmitInstrs (mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy testInstr) @@ -644,7 +661,7 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a let baseTesterMeths, baseTesterProps = if cud.cudAlternatives.Length <= 1 then [], [] - elif repr.OptimizingOneAlternativeToNull info then [], [] + elif repr.RepresentOneAlternativeAsNull info then [], [] else [ mkILNonGenericInstanceMethod ("get_" + mkTesterName altName, @@ -719,8 +736,8 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a [], [] let typeDefs, altDebugTypeDefs, altNullaryFields = - if repr.OptimizeAlternativeToNull (info,alt) then [], [], [] - elif repr.OptimizeSingleNonNullaryAlternativeToRootClass (info,alt) then [], [], [] + if repr.RepresentAlternativeAsNull (info,alt) then [], [], [] + elif repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt) then [], [], [] else let altNullaryFields = if repr.MaintainPossiblyUniqueConstantFieldForAlternative(info,alt) then @@ -770,7 +787,8 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a mkMethodBody(true,emptyILLocals,2, nonBranchingInstrsToCode [ mkLdarg0 - mkNormalLdfld (mkILFieldSpecInTy (debugProxyTy,debugProxyFieldName,altTy)) + (match td.tdKind with ILTypeDefKind.ValueType -> mkNormalLdflda | _ -> mkNormalLdfld) + (mkILFieldSpecInTy (debugProxyTy,debugProxyFieldName,altTy)) mkNormalLdfld (mkILFieldSpecInTy(altTy,fldName,fldTy))],None)) |> addMethodGeneratedAttrs ilg) |> Array.toList @@ -863,8 +881,9 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a let mkClassUnionDef ilg tref td cud = - let baseTy = mkILFormalBoxedTy tref td.GenericParams - let cuspec = IlxUnionSpec(IlxUnionRef(baseTy.TypeRef, cud.cudAlternatives, cud.cudNullPermitted, cud.cudHasHelpers), baseTy.GenericArgs) + let boxity = match td.tdKind with ILTypeDefKind.ValueType -> ILBoxity.AsValue | _ -> ILBoxity.AsObject + let baseTy = mkILFormalNamedTy boxity tref td.GenericParams + let cuspec = IlxUnionSpec(IlxUnionRef(boxity,baseTy.TypeRef, cud.cudAlternatives, cud.cudNullPermitted, cud.cudHasHelpers), baseTy.GenericArgs) let info = (td,cud) let repr = cudefRepr let isTotallyImmutable = (cud.cudHasHelpers <> SpecialFSharpListHelpers) @@ -886,24 +905,33 @@ let mkClassUnionDef ilg tref td cud = | SingleCase | RuntimeTypes | TailOrNull -> [] | IntegerTag -> [ mkTagFieldId ilg cuspec ] - let selfFields, selfMeths, selfProps, _ = - match cud.cudAlternatives |> Array.toList |> List.findi 0 (fun alt -> repr.OptimizeSingleNonNullaryAlternativeToRootClass (info,alt)) with - | Some (alt,altNum) -> - let fields = (alt.FieldDefs |> Array.toList |> List.map mkUnionCaseFieldId) + let selfFields, selfMeths, selfProps = + + [ for alt in cud.cudAlternatives do + if repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt) then + // TODO + let fields = alt.FieldDefs |> Array.toList |> List.map mkUnionCaseFieldId + let baseInit = + match td.tdKind with + | ILTypeDefKind.ValueType -> None + | _ -> + match td.Extends with + | None -> Some ilg.tspec_Object + | Some typ -> Some typ.TypeSpec + let ctor = mkILSimpleStorageCtor (cud.cudWhere, - (match td.Extends with None -> Some ilg.tspec_Object | Some typ -> Some typ.TypeSpec), + baseInit, baseTy, (fields @ tagFieldsInObject), (if cuspec.HasHelpers = AllHelpers then ILMemberAccess.Assembly else cud.cudReprAccess)) |> addMethodGeneratedAttrs ilg let props, meths = mkMethodsAndPropertiesForFields ilg cud.cudReprAccess cud.cudWhere cud.cudHasHelpers baseTy alt.FieldDefs - fields,([ctor] @ meths),props,altNum - - | None -> - [],[],[],0 + yield (fields,([ctor] @ meths),props) ] + |> List.unzip3 + |> (fun (a,b,c) -> List.concat a, List.concat b, List.concat c) let selfAndTagFields = [ for (fldName,fldTy) in (selfFields @ tagFieldsInObject) do @@ -912,7 +940,7 @@ let mkClassUnionDef ilg tref td cud = let ctorMeths = if (isNil selfFields && isNil tagFieldsInObject && nonNil selfMeths) - || cud.cudAlternatives |> Array.forall (fun alt -> repr.OptimizeSingleNonNullaryAlternativeToRootClass (info,alt)) then + || cud.cudAlternatives |> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt)) then [] (* no need for a second ctor in these cases *) @@ -962,7 +990,7 @@ let mkClassUnionDef ilg tref td cud = let body = mkMethodBody(true,emptyILLocals,2,genWith (fun cg -> emitLdDataTagPrim ilg (Some mkLdarg0) cg (true, cuspec); cg.EmitInstr I_ret), cud.cudWhere) // // If we are using NULL as a representation for an element of this type then we cannot // // use an instance method - if (repr.OptimizingOneAlternativeToNull info) then + if (repr.RepresentOneAlternativeAsNull info) then [ mkILNonGenericStaticMethod("Get" + tagPropertyName,cud.cudHelpersAccess,[mkILParamAnon baseTy],mkILReturn tagFieldType,body) |> addMethodGeneratedAttrs ilg ], [] @@ -1024,28 +1052,16 @@ let mkClassUnionDef ilg tref td cud = tdKind = ILTypeDefKind.Enum } let baseTypeDef = - { Name = td.Name + { td with NestedTypes = mkILTypeDefs (Option.toList enumTypeDef @ altTypeDefs @ altDebugTypeDefs @ td.NestedTypes.AsList) - GenericParams= td.GenericParams - Access = td.Access IsAbstract = isAbstract IsSealed = altTypeDefs.IsEmpty - IsSerializable=td.IsSerializable IsComInterop=false - Layout=td.Layout - IsSpecialName=td.IsSpecialName - Encoding=td.Encoding - Implements = td.Implements Extends= (match td.Extends with None -> Some ilg.typ_Object | _ -> td.Extends) Methods= mkILMethods (ctorMeths @ baseMethsFromAlt @ selfMeths @ tagMeths @ altUniqObjMeths @ existingMeths) - SecurityDecls=td.SecurityDecls - HasSecurity=td.HasSecurity Fields=mkILFields (selfAndTagFields @ List.map (fun (_,_,_,_,fdef,_) -> fdef) altNullaryFields @ td.Fields.AsList) - MethodImpls=td.MethodImpls InitSemantics=ILTypeInit.BeforeField - Events=td.Events Properties=mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps) - CustomAttrs=td.CustomAttrs tdKind = ILTypeDefKind.Class } // The .cctor goes on the Cases type since that's where the constant fields for nullary constructors live |> addConstFieldInit diff --git a/src/ilx/EraseUnions.fsi b/src/ilx/EraseUnions.fsi index 09d5e41e29de..47311b277009 100644 --- a/src/ilx/EraseUnions.fsi +++ b/src/ilx/EraseUnions.fsi @@ -9,19 +9,22 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.EraseUnions open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types -/// Make the instruction sequence for an ILX "newdata" instruction +/// Make the instruction sequence for a "newdata" operation val mkNewData : ILGlobals -> IlxUnionSpec * int -> ILInstr list -/// Make the instruction sequence for an ILX "isdata" instruction +/// Make the instruction sequence for a "isdata" operation val mkIsData : ILGlobals -> bool * IlxUnionSpec * int -> ILInstr list -/// Make the instruction sequence for an ILX "lddata" instruction +/// Make the instruction sequence for a "lddata" operation val mkLdData : bool * IlxUnionSpec * int * int -> ILInstr list -/// Make the instruction sequence for an ILX "stdata" instruction +/// Make the instruction sequence for a "lddataa" operation +val mkLdDataAddr : bool * IlxUnionSpec * int * int -> ILInstr list + +/// Make the instruction sequence for a "stdata" operation val mkStData : IlxUnionSpec * int * int -> ILInstr list -/// Make the instruction sequence for an ILX "brisnotdata" instruction +/// Make the instruction sequence for a "brisnotdata" operation val mkBrIsNotData : ILGlobals -> avoidHelpers:bool * IlxUnionSpec * int * ILCodeLabel -> ILInstr list /// Make the type definition for a union type @@ -39,11 +42,11 @@ type ICodeGen<'Mark> = abstract EmitInstr : ILInstr -> unit abstract EmitInstrs : ILInstr list -> unit -/// Emit the instruction sequence for an ILX "castdata" instruction -val emitCastData : ILGlobals -> ICodeGen<'Mark> -> canfail: bool * IlxUnionSpec * int -> unit +/// Emit the instruction sequence for a "castdata" operation +val emitCastData : ILGlobals -> ICodeGen<'Mark> -> canfail: bool * avoidHelpers:bool * IlxUnionSpec * int -> unit -/// Emit the instruction sequence for an ILX "lddatatag" instruction +/// Emit the instruction sequence for a "lddatatag" operation val emitLdDataTag : ILGlobals -> ICodeGen<'Mark> -> avoidHelpers:bool * IlxUnionSpec -> unit -/// Emit the instruction sequence for an ILX "switchdata" instruction +/// Emit the instruction sequence for a "switchdata" operation val emitDataSwitch : ILGlobals -> ICodeGen<'Mark> -> avoidHelpers:bool * IlxUnionSpec * (int * ILCodeLabel) list -> unit diff --git a/tests/fsharp/typecheck/sigs/neg95.bsl b/tests/fsharp/typecheck/sigs/neg95.bsl index 63c66b9823f5..77c5eb51c38f 100644 --- a/tests/fsharp/typecheck/sigs/neg95.bsl +++ b/tests/fsharp/typecheck/sigs/neg95.bsl @@ -1,2 +1,6 @@ -neg94.fs(5,6,5,18): typecheck error FS0954: This type definition involves an immediate cyclic reference through a struct field or inheritance relation \ No newline at end of file +neg95.fs(5,6,5,18): typecheck error FS0954: This type definition involves an immediate cyclic reference through a struct field or inheritance relation + +neg95.fs(12,6,12,17): typecheck error FS0954: This type definition involves an immediate cyclic reference through a struct field or inheritance relation + +neg95.fs(15,6,15,18): typecheck error FS3199: A union type which is a struct must have only one case. \ No newline at end of file diff --git a/tests/fsharp/typecheck/sigs/neg95.fs b/tests/fsharp/typecheck/sigs/neg95.fs index 3a58778211ba..6422fa140459 100644 --- a/tests/fsharp/typecheck/sigs/neg95.fs +++ b/tests/fsharp/typecheck/sigs/neg95.fs @@ -7,3 +7,9 @@ type StructRecord = X: float Y: StructRecord } + +[] +type StructUnion = StructUnion of float * StructUnion + +[] +type StructUnion2 = A of int | B of string From 75eec14421e5565965c6e99434dc0ac52d84743b Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Jun 2016 20:52:12 +0100 Subject: [PATCH 02/12] struct unions --- src/fsharp/AugmentWithHashCompare.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fsharp/AugmentWithHashCompare.fs b/src/fsharp/AugmentWithHashCompare.fs index 842561c857b2..8c59387adfd1 100644 --- a/src/fsharp/AugmentWithHashCompare.fs +++ b/src/fsharp/AugmentWithHashCompare.fs @@ -222,7 +222,7 @@ let mkRecdCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_,thate) com (mkRecdFieldGetViaExprAddr(thataddre, fref, tinst, m)) let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise tce expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr let expr = mkBindThatAddr g m ty thataddrv tcv tce expr // will be optimized away if not necessary @@ -436,7 +436,7 @@ let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatv,that (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise tce expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr let expr = mkBindThatAddr g m ty thataddrv tcv tce expr // will be optimized away if not necessary let expr = mkCompGenLet m tcv thate expr From 4153ebbf428b61c800a82b6a2fdb9b36c0ebcacf Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Jun 2016 23:13:48 +0100 Subject: [PATCH 03/12] fix for test --- src/fsharp/AugmentWithHashCompare.fs | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src/fsharp/AugmentWithHashCompare.fs b/src/fsharp/AugmentWithHashCompare.fs index 8c59387adfd1..2769415f6562 100644 --- a/src/fsharp/AugmentWithHashCompare.fs +++ b/src/fsharp/AugmentWithHashCompare.fs @@ -111,6 +111,11 @@ let mkCombineHashGenerators g m exprs accv acce = //------------------------------------------------------------------------- let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) +let mkThatAddrLocalIfNeeded g m tcve ty = + if isStructTy g ty then + let thataddrv, thataddre = mkCompGenLocal m "obj" (mkThisTy g ty) + Some thataddrv, thataddre + else None,tcve let mkThisVarThatVar g m ty = let thisv,thise = mkThisVar g m ty @@ -129,6 +134,12 @@ let mkBindThatAddr g m ty thataddrv thatv thate expr = else mkCompGenLet m thataddrv thate expr +let mkBindThatAddrIfNeeded g m ty thataddrvOpt thatv thate expr = + match thataddrvOpt with + | None -> expr + | Some thataddrv -> + mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr + let mkDerefThis g m (thisv: Val) thise = if isByrefTy g thisv.Type then mkAddrGet m (mkLocalValRef thisv) else thise @@ -210,7 +221,7 @@ let mkRecdCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_,thate) com let fields = tycon.AllInstanceFieldsAsList let tinst,ty = mkMinimalTy g tcref let tcv,tce = mkCompGenLocal m "objTemp" ty // let tcv = thate - let thataddrv,thataddre = mkThatAddrLocal g m ty // let thataddrv = &tcv, if a struct + let thataddrv,thataddre = mkThatAddrLocal g m tce ty // let thataddrv = &tcv, if a struct let mkTest (fspec:RecdField) = let fty = fspec.FormalType @@ -381,14 +392,14 @@ let mkUnionCompare g tcref (tycon:Tycon) = /// Build the comparison implementation for a union type when parameterized by a comparer -let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatv,thate) compe = +let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatobjv,thatcaste) compe = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref + let tcv,tce = mkCompGenLocal m "objTemp" ty // let tcv = (thatobj :?> ty) + let thataddrvOpt,thataddre = mkThatAddrLocalIfNeeded g m tce ty // let thataddrv = &tcv if struct, otherwise thataddre is just tce let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty - let thataddrv,thataddre = mkThatAddrLocal g m ty - let tcv,tce = mkCompGenLocal m "objTemp" ty // let tcv = thate let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) @@ -436,10 +447,9 @@ let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatv,that (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr - let expr = mkBindThatAddr g m ty thataddrv tcv tce expr - // will be optimized away if not necessary - let expr = mkCompGenLet m tcv thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thatcaste expr + let expr = mkBindThatAddrIfNeeded g m ty thataddrvOpt tcv tce expr + let expr = mkCompGenLet m tcv thatcaste expr expr From 93f8799d5e57666891fa1cf9395a84e5c01e279f Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Jun 2016 23:20:31 +0100 Subject: [PATCH 04/12] fix for test --- src/fsharp/AugmentWithHashCompare.fs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/fsharp/AugmentWithHashCompare.fs b/src/fsharp/AugmentWithHashCompare.fs index 2769415f6562..5199dc223ccf 100644 --- a/src/fsharp/AugmentWithHashCompare.fs +++ b/src/fsharp/AugmentWithHashCompare.fs @@ -130,14 +130,17 @@ let mkThatVarBind g m ty thataddrv expr = let mkBindThatAddr g m ty thataddrv thatv thate expr = if isStructTy g ty then - mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr + // let thataddrv = &thatv + mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr else - mkCompGenLet m thataddrv thate expr + // let thataddrv = that + mkCompGenLet m thataddrv thate expr -let mkBindThatAddrIfNeeded g m ty thataddrvOpt thatv thate expr = +let mkBindThatAddrIfNeeded m thataddrvOpt thatv expr = match thataddrvOpt with | None -> expr | Some thataddrv -> + // let thataddrv = &thatv mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr let mkDerefThis g m (thisv: Val) thise = @@ -221,7 +224,7 @@ let mkRecdCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_,thate) com let fields = tycon.AllInstanceFieldsAsList let tinst,ty = mkMinimalTy g tcref let tcv,tce = mkCompGenLocal m "objTemp" ty // let tcv = thate - let thataddrv,thataddre = mkThatAddrLocal g m tce ty // let thataddrv = &tcv, if a struct + let thataddrv,thataddre = mkThatAddrLocal g m ty // let thataddrv = &tcv, if a struct let mkTest (fspec:RecdField) = let fty = fspec.FormalType @@ -448,7 +451,7 @@ let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatobjv,t tagsEqTested) let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thatcaste expr - let expr = mkBindThatAddrIfNeeded g m ty thataddrvOpt tcv tce expr + let expr = mkBindThatAddrIfNeeded m thataddrvOpt tcv expr let expr = mkCompGenLet m tcv thatcaste expr expr From 47077f6e7112f654ba3f2af9dd24219ce3ced8e5 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Jun 2016 23:46:37 +0100 Subject: [PATCH 05/12] limit conditional build and add more tests --- .../FSharp.Core.Unittests.fsproj | 2 +- .../FSharp.Core/RecordTypes.fs | 46 ++++++++++++++++++- 2 files changed, 46 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj index 83ed633defad..4fc578c8f052 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj @@ -112,7 +112,7 @@ - + diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/RecordTypes.fs b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/RecordTypes.fs index 694052fa4d2b..2d9695b08fab 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/RecordTypes.fs +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/RecordTypes.fs @@ -325,4 +325,48 @@ let [] ``can properly construct a struct record using FSharpValue.MakeReco let d = (fields.[1] :?> int) Assert.AreEqual (999, d) - \ No newline at end of file +type DefaultLayoutMutableRecord = + { mutable First : int + mutable Second : float + mutable Third : decimal + mutable Fourth : int + } + +let inline CX_get_A(x: ^T) = + ( (^T : (member A : int) (x)) ) + +let inline CX_get_C(x: ^T) = + ( (^T : (member C : int) (x)) ) + +let inline CX_set_First(x: ^T, v) = + ( (^T : (member First : int with set) (x,v)) ) + + +type Members() = + static member CreateMutableStructRecord() = { M1 = 1; M2 = 2 } + + +let [] ``inline constraints resolve correctly`` () = + let v = CX_get_A ({ A = 1; B = 2 }) + Assert.AreEqual (1, v) + + let v2 = CX_get_C ({ C = 1; D = 2 }) + Assert.AreEqual (1, v2) + + let mutable m : DefaultLayoutMutableRecord = + { First = 0xbaad1 + Second = 0.987654 + Third = 100.32M + Fourth = 0xbaad4 } + + let v3 = CX_set_First (m,1) + Assert.AreEqual (1, m.First) + +let [] ``member setters resolve correctly`` () = + + let v = Members.CreateMutableStructRecord() + Assert.AreEqual (1, v.M1) + + //let v2 = Members.CreateMutableStructRecord(M1 = 100) + //Assert.AreEqual (100, v2.M1) + From 28d4b053d2600c31a99767e399efa77a0815b510 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 16 Jun 2016 10:19:19 +0100 Subject: [PATCH 06/12] fix tests --- .../ToplevelModule.il.bsl | 8 ++++---- .../ToplevelModuleP.il.bsl | 8 ++++---- .../ToplevelNamespace.il.bsl | 10 +++++----- .../ToplevelNamespaceP.il.bsl | 10 +++++----- .../Optimizations/Inlining/Match01.il.bsl | Bin 129528 -> 129528 bytes 5 files changed, 18 insertions(+), 18 deletions(-) diff --git a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModule.il.bsl b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModule.il.bsl index 075b68845eee..972eced84a07 100644 --- a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModule.il.bsl +++ b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModule.il.bsl @@ -36,13 +36,13 @@ // Offset: 0x00001158 Length: 0x000003FD } .module TopLevelModule.dll -// MVID: {575BE147-37F5-C118-A745-038347E15B57} +// MVID: {576266DB-37F5-C118-A745-0383DB666257} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x00620000 +// Image base: 0x01090000 // =============== CLASS MEMBERS DECLARATION =================== @@ -685,7 +685,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 @@ -1483,7 +1483,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 diff --git a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModuleP.il.bsl b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModuleP.il.bsl index 76df7a86bfb5..51e5cc6249a3 100644 --- a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModuleP.il.bsl +++ b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelModuleP.il.bsl @@ -36,13 +36,13 @@ // Offset: 0x00001158 Length: 0x000003FE } .module ToplevelModuleP.dll -// MVID: {575BE155-5A3A-8E4D-A745-038355E15B57} +// MVID: {576266E1-5A3A-8E4D-A745-0383E1666257} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x009B0000 +// Image base: 0x00A70000 // =============== CLASS MEMBERS DECLARATION =================== @@ -671,7 +671,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 @@ -1455,7 +1455,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 diff --git a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespace.il.bsl b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespace.il.bsl index 1d33d16bc4cb..b9d03a5dc596 100644 --- a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespace.il.bsl +++ b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespace.il.bsl @@ -36,13 +36,13 @@ // Offset: 0x00001860 Length: 0x0000055C } .module ToplevelNamespace.dll -// MVID: {575BE14E-218B-729A-A745-03834EE15B57} +// MVID: {576266DE-218B-729A-A745-0383DE666257} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x00F30000 +// Image base: 0x00D30000 // =============== CLASS MEMBERS DECLARATION =================== @@ -680,7 +680,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 @@ -1478,7 +1478,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 @@ -2276,7 +2276,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 diff --git a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespaceP.il.bsl b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespaceP.il.bsl index 159318722296..a419b7a9c0c5 100644 --- a/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespaceP.il.bsl +++ b/tests/fsharpqa/Source/CodeGen/EmittedIL/SerializableAttribute/ToplevelNamespaceP.il.bsl @@ -36,13 +36,13 @@ // Offset: 0x00001860 Length: 0x0000055D } .module ToplevelNamespaceP.dll -// MVID: {575BE15B-88D9-D7FD-A745-03835BE15B57} +// MVID: {576266E4-88D9-D7FD-A745-0383E4666257} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x003C0000 +// Image base: 0x01450000 // =============== CLASS MEMBERS DECLARATION =================== @@ -666,7 +666,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 @@ -1450,7 +1450,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 @@ -2234,7 +2234,7 @@ IL_0019: ldloc.0 IL_001a: stloc.1 - IL_001b: ldloc.1 + IL_001b: ldloc.0 IL_001c: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) IL_0021: brtrue.s IL_0025 diff --git a/tests/fsharpqa/Source/Optimizations/Inlining/Match01.il.bsl b/tests/fsharpqa/Source/Optimizations/Inlining/Match01.il.bsl index ddfd9dfcac162f511522f832a3e03e63377203a5..523f7efed861a5c2664420a96c43c1ce833e2920 100644 GIT binary patch delta 41 zcmV+^0M`Hb^9T6z2Y|Ez!q5j)0A&De0C1Nf&;fs!fHMJ3w~(p Date: Thu, 16 Jun 2016 17:05:41 +0100 Subject: [PATCH 07/12] minor fixes and more testing --- .../FSharp.Core/DiscrimantedUnionType.fs | 23 ++++ src/fsharp/PatternMatchCompilation.fs | 70 +++++------ src/ilx/EraseUnions.fs | 8 +- tests/fsharp/core/attributes/testlib.fs | 2 + tests/fsharp/core/fsfromcs/{lib.ml => lib.fs} | 2 +- .../core/fsfromfsviacs/{lib.ml => lib.fs} | 72 ++++++++++- tests/fsharp/core/fsfromfsviacs/lib2.cs | 4 + tests/fsharp/core/fsfromfsviacs/test.fsx | 64 ++++++++++ tests/fsharp/core/quotes/test.fsx | 119 +++++------------- tests/fsharp/core/tests_core.fs | 12 +- 10 files changed, 242 insertions(+), 134 deletions(-) rename tests/fsharp/core/fsfromcs/{lib.ml => lib.fs} (99%) rename tests/fsharp/core/fsfromfsviacs/{lib.ml => lib.fs} (51%) diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs index 52ea6fbf3889..73f548920dc9 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs @@ -226,3 +226,26 @@ let ``struct unions hold [] [] metadata`` () = Assert.IsTrue (hasAttribute()) Assert.IsTrue (hasAttribute()) + +let [] ``can properly construct a struct union using FSharpValue.MakeUnionCase, and we get the fields`` () = + let cases = Microsoft.FSharp.Reflection.FSharpType.GetUnionCases(typeof) + + Assert.AreEqual (1, cases.Length) + let case = cases.[0] + + Assert.AreEqual ("SU", case.Name) + + let structUnion = Microsoft.FSharp.Reflection.FSharpValue.MakeUnion (case, [|box 1234; box 3456|]) + + Assert.IsTrue (structUnion.GetType().IsValueType) + + let fieldVals = Microsoft.FSharp.Reflection.FSharpValue.GetUnionFields(structUnion, typeof) + + Assert.AreEqual (2, fieldVals.Length) + + let c = (fieldVals.[0] :?> int) + Assert.AreEqual (1234, c) + + let c2 = (fieldVals.[1] :?> int) + Assert.AreEqual (3456, c2) + diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 22400641b797..6bff652145d7 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -493,7 +493,7 @@ let (|ListEmptyDiscrim|_|) g = function /// - Compact integer switches become a single switch. Non-compact integer /// switches, string switches and floating point switches are treated in the /// same way as Test.IsInst. -let rec BuildSwitch resPreBindOpt g expr edges dflt m = +let rec BuildSwitch inpExprOpt g expr edges dflt m = if verbose then dprintf "--> BuildSwitch@%a, #edges = %A, dflt.IsSome = %A\n" outputRange m (List.length edges) (Option.isSome dflt); match edges,dflt with | [], None -> failwith "internal error: no edges and no default" @@ -505,12 +505,12 @@ let rec BuildSwitch resPreBindOpt g expr edges dflt m = // 'isinst' tests where we have stored the result of the 'isinst' in a variable // In this case the 'expr' already holds the result of the 'isinst' test. - | (TCase(Test.IsInst _,success)):: edges, dflt when isSome resPreBindOpt -> + | (TCase(Test.IsInst _,success)):: edges, dflt when isSome inpExprOpt -> TDSwitch(expr,[TCase(Test.IsNull,BuildSwitch None g expr edges dflt m)],Some success,m) // isnull and isinst tests | (TCase((Test.IsNull | Test.IsInst _),_) as edge):: edges, dflt -> - TDSwitch(expr,[edge],Some (BuildSwitch resPreBindOpt g expr edges dflt m),m) + TDSwitch(expr,[edge],Some (BuildSwitch inpExprOpt g expr edges dflt m),m) #if OPTIMIZE_LIST_MATCHING // 'cons/nil' tests where we have stored the result of the cons test in an 'isinst' in a variable @@ -519,7 +519,7 @@ let rec BuildSwitch resPreBindOpt g expr edges dflt m = | [TCase(ListEmptyDiscrim g tinst, emptyCase)], Some consCase | [TCase(ListEmptyDiscrim g _, emptyCase); TCase(ListConsDiscrim g tinst, consCase)], None | [TCase(ListConsDiscrim g tinst, consCase); TCase(ListEmptyDiscrim g _, emptyCase)], None - when isSome resPreBindOpt -> + when isSome inpExprOpt -> TDSwitch(expr, [TCase(Test.IsNull, emptyCase)], Some consCase, m) #endif @@ -792,10 +792,10 @@ let CompilePatternBasic if debug then dprintf "chooseSimultaneousEdgeSet\n"; let simulSetOfEdgeDiscrims,fallthroughPathFrontiers = ChooseSimultaneousEdges frontiers path - let resPreBindOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr + let inpExprOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr // For each case, recursively compile the residue decision trees that result if that case successfully matches - let simulSetOfCases, _ = CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims resPreBindOpt + let simulSetOfCases, _ = CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims inpExprOpt assert (nonNil(simulSetOfCases)); @@ -812,8 +812,8 @@ let CompilePatternBasic // OK, build the whole tree and whack on the binding if any let finalDecisionTree = - let inpExprToSwitch = (match resPreBindOpt with Some vexp -> vexp | None -> GetSubExprOfInput subexpr) - let tree = BuildSwitch resPreBindOpt g inpExprToSwitch simulSetOfCases defaultTreeOpt matchm + let inpExprToSwitch = (match inpExprOpt with Some vexp -> vexp | None -> GetSubExprOfInput subexpr) + let tree = BuildSwitch inpExprOpt g inpExprToSwitch simulSetOfCases defaultTreeOpt matchm match bindOpt with | None -> tree | Some bind -> TDBind (bind,tree) @@ -904,7 +904,7 @@ let CompilePatternBasic let argexp = GetSubExprOfInput subexpr let vOpt,addrexp = mkExprAddrOfExprAux g true false NeverMutates argexp None matchm match vOpt with - | None -> None, None + | None -> Some addrexp, None | Some (v,e) -> if topv.IsMemberOrModuleBinding then AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; @@ -945,7 +945,7 @@ let CompilePatternBasic | _ -> None,None - and CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims (resPreBindOpt: Expr option) = + and CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims (inpExprOpt: Expr option) = ([],simulSetOfEdgeDiscrims) ||> List.collectFold (fun taken (EdgeDiscrim(i',discrim,m)) -> // Check to see if we've already collected the edge for this case, in which case skip it. @@ -968,7 +968,7 @@ let CompilePatternBasic match discrim with | Test.UnionCase (ucref, tinst) when #if OPTIMIZE_LIST_MATCHING - isNone resPreBindOpt && + isNone inpExprOpt && #endif (isNil topgtvs && not topv.IsMemberOrModuleBinding && @@ -1000,7 +1000,7 @@ let CompilePatternBasic // Project a successful edge through the frontiers. let investigation = Investigation(i',discrim,path) - let frontiers = frontiers |> List.collect (GenerateNewFrontiersAfterSucccessfulInvestigation resPreBindOpt resPostBindOpt investigation) + let frontiers = frontiers |> List.collect (GenerateNewFrontiersAfterSucccessfulInvestigation inpExprOpt resPostBindOpt investigation) let tree = InvestigateFrontiers refuted frontiers // Bind the resVar for the union case, if we have one let tree = @@ -1042,7 +1042,7 @@ let CompilePatternBasic // Build a new frontier that represents the result of a successful investigation // at rule point (i',discrim,path) - and GenerateNewFrontiersAfterSucccessfulInvestigation resPreBindOpt resPostBindOpt (Investigation(i',discrim,path)) (Frontier (i, active,valMap) as frontier) = + and GenerateNewFrontiersAfterSucccessfulInvestigation inpExprOpt resPostBindOpt (Investigation(i',discrim,path)) (Frontier (i, active,valMap) as frontier) = if debug then dprintf "projecting success of investigation encompassing rule %d through rule %d \n" i' i; if (isMemOfActives path active) then @@ -1068,14 +1068,14 @@ let CompilePatternBasic if (hasParam && i = i') || (discrimsEq g discrim (Option.get (getDiscrimOfPattern pat))) then let aparity = apinfo.Names.Length let accessf' j tpinst _e' = - assert resPreBindOpt.IsSome + assert inpExprOpt.IsSome if aparity <= 1 then - Option.get resPreBindOpt + Option.get inpExprOpt else let ucref = mkChoiceCaseRef g m aparity idx // TODO: In the future we will want active patterns to be able to return struct-unions // In that eventuality, we need to check we are taking the address correctly - mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get resPreBindOpt,ucref,instTypes tpinst resTys,j,exprm) + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get inpExprOpt,ucref,instTypes tpinst resTys,j,exprm) mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j)) elif hasParam then @@ -1089,7 +1089,7 @@ let CompilePatternBasic let accessf' _j tpinst _ = // TODO: In the future we will want active patterns to be able to return struct-unions // In that eventuality, we need to check we are taking the address correctly - mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get resPreBindOpt, mkSomeCase g, instTypes tpinst resTys, 0, exprm) + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get inpExprOpt, mkSomeCase g, instTypes tpinst resTys, 0, exprm) mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j)) else // Successful active patterns don't refute other patterns @@ -1098,15 +1098,15 @@ let CompilePatternBasic | TPat_unioncase (ucref1, tyargs, argpats,_) -> match discrim with | Test.UnionCase (ucref2, tinst) when g.unionCaseRefEq ucref1 ucref2 -> - let accessf' j tpinst e' = -#if OPTIMIZE_LIST_MATCHING - match resPreBindOpt with - | Some e -> mkUnionCaseFieldGetProvenViaExprAddr g (e,ucref1,tinst,j,exprm) - | None -> -#endif + let accessf' j tpinst exprIn = match resPostBindOpt with | Some e -> mkUnionCaseFieldGetProvenViaExprAddr (e,ucref1,tinst,j,exprm) - | None -> mkUnionCaseFieldGetUnprovenViaExprAddr (accessf tpinst e',ucref1,instTypes tpinst tyargs,j,exprm) + | None -> + let exprIn = + match inpExprOpt with + | Some addrexp -> addrexp + | None -> accessf tpinst exprIn + mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn,ucref1,instTypes tpinst tyargs,j,exprm) mkSubFrontiers path accessf' active' argpats (fun path j -> PathUnionConstr(path,ucref1,tyargs,j)) | Test.UnionCase _ -> @@ -1119,7 +1119,7 @@ let CompilePatternBasic | TPat_array (argpats,ty,_) -> match discrim with | Test.ArrayLength (n,_) when List.length argpats = n -> - let accessf' j tpinst e' = mkCallArrayGet g exprm ty (accessf tpinst e') (mkInt g exprm j) + let accessf' j tpinst exprIn = mkCallArrayGet g exprm ty (accessf tpinst exprIn) (mkInt g exprm j) mkSubFrontiers path accessf' active' argpats (fun path j -> PathArray(path,ty,List.length argpats,j)) // Successful length tests refute all other lengths | Test.ArrayLength _ -> @@ -1130,7 +1130,7 @@ let CompilePatternBasic | TPat_exnconstr (ecref, argpats,_) -> match discrim with | Test.IsInst (_srcTy,tgtTy) when typeEquiv g (mkAppTy ecref []) tgtTy -> - let accessf' j tpinst e' = mkExnCaseFieldGet(accessf tpinst e',ecref,j,exprm) + let accessf' j tpinst exprIn = mkExnCaseFieldGet(accessf tpinst exprIn,ecref,j,exprm) mkSubFrontiers path accessf' active' argpats (fun path j -> PathExnConstr(path,ecref,j)) | _ -> // Successful type tests against one sealed type refute all other sealed types @@ -1142,16 +1142,16 @@ let CompilePatternBasic | Test.IsInst (_srcTy,tgtTy2) when typeEquiv g tgtTy1 tgtTy2 -> match pbindOpt with | Some pbind -> - let accessf' tpinst e' = + let accessf' tpinst exprIn = // Fetch the result from the place where we saved it, if possible - match resPreBindOpt with + match inpExprOpt with | Some e -> e | _ -> // Otherwise call the helper - mkCallUnboxFast g exprm (instType tpinst tgtTy1) (accessf tpinst e') + mkCallUnboxFast g exprm (instType tpinst tgtTy1) (accessf tpinst exprIn) - let (v,e') = BindSubExprOfInput g amap topgtvs pbind exprm (SubExpr(accessf',ve)) - [Frontier (i, active', valMap.Add v e' )] + let (v,exprIn) = BindSubExprOfInput g amap topgtvs pbind exprm (SubExpr(accessf',ve)) + [Frontier (i, active', valMap.Add v exprIn )] | None -> [Frontier (i, active', valMap)] @@ -1190,17 +1190,17 @@ let CompilePatternBasic | TPat_wild _ -> BindProjectionPatterns [] s | TPat_as(p',pbind,m) -> - let (v,e') = BindSubExprOfInput g amap topgtvs pbind m subExpr - BindProjectionPattern (Active(path,subExpr,p')) (accActive,accValMap.Add v e' ) + let (v,subExpr') = BindSubExprOfInput g amap topgtvs pbind m subExpr + BindProjectionPattern (Active(path,subExpr,p')) (accActive,accValMap.Add v subExpr' ) | TPat_tuple(ps,tyargs,_m) -> - let accessf' j tpinst e' = mkTupleFieldGet(accessf tpinst e',instTypes tpinst tyargs,j,exprm) + let accessf' j tpinst exprIn = mkTupleFieldGet(accessf tpinst exprIn,instTypes tpinst tyargs,j,exprm) let pathBuilder path j = PathTuple(path,tyargs,j) let newActives = List.mapi (mkSubActive pathBuilder accessf') ps BindProjectionPatterns newActives s | TPat_recd(tcref,tinst,ps,_m) -> let newActives = (ps,tcref.TrueInstanceFieldsAsRefList) ||> List.mapi2 (fun j p fref -> - let accessf' fref _j tpinst e' = mkRecdFieldGet g (accessf tpinst e',fref,instTypes tpinst tinst,exprm) + let accessf' fref _j tpinst exprIn = mkRecdFieldGet g (accessf tpinst exprIn,fref,instTypes tpinst tinst,exprm) let pathBuilder path j = PathRecd(path,tcref,tinst,j) mkSubActive pathBuilder (accessf' fref) j p) BindProjectionPatterns newActives s diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index c4cdfab06256..6edcb4c663bb 100644 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -905,6 +905,8 @@ let mkClassUnionDef ilg tref td cud = | SingleCase | RuntimeTypes | TailOrNull -> [] | IntegerTag -> [ mkTagFieldId ilg cuspec ] + let isStruct = match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false + let selfFields, selfMeths, selfProps = [ for alt in cud.cudAlternatives do @@ -912,9 +914,7 @@ let mkClassUnionDef ilg tref td cud = // TODO let fields = alt.FieldDefs |> Array.toList |> List.map mkUnionCaseFieldId let baseInit = - match td.tdKind with - | ILTypeDefKind.ValueType -> None - | _ -> + if isStruct then None else match td.Extends with | None -> Some ilg.tspec_Object | Some typ -> Some typ.TypeSpec @@ -936,7 +936,7 @@ let mkClassUnionDef ilg tref td cud = let selfAndTagFields = [ for (fldName,fldTy) in (selfFields @ tagFieldsInObject) do let fdef = mkHiddenGeneratedInstanceFieldDef ilg (fldName,fldTy, None, ILMemberAccess.Assembly) - yield { fdef with IsInitOnly=isTotallyImmutable } ] + yield { fdef with IsInitOnly= (not isStruct && isTotallyImmutable) } ] let ctorMeths = if (isNil selfFields && isNil tagFieldsInObject && nonNil selfMeths) diff --git a/tests/fsharp/core/attributes/testlib.fs b/tests/fsharp/core/attributes/testlib.fs index e5f00296b2ca..eddb622fccc5 100644 --- a/tests/fsharp/core/attributes/testlib.fs +++ b/tests/fsharp/core/attributes/testlib.fs @@ -116,3 +116,5 @@ module TypeParamAttributesDifferent = type ThisLibAssembly = X | Y + + diff --git a/tests/fsharp/core/fsfromcs/lib.ml b/tests/fsharp/core/fsfromcs/lib.fs similarity index 99% rename from tests/fsharp/core/fsfromcs/lib.ml rename to tests/fsharp/core/fsfromcs/lib.fs index 4e9936fb13c7..1ca7ef43135f 100644 --- a/tests/fsharp/core/fsfromcs/lib.ml +++ b/tests/fsharp/core/fsfromcs/lib.fs @@ -1,4 +1,4 @@ - +module Lib (* An F# library which we try to access from C# *) type Recd1 = { recd1field1: int } diff --git a/tests/fsharp/core/fsfromfsviacs/lib.ml b/tests/fsharp/core/fsfromfsviacs/lib.fs similarity index 51% rename from tests/fsharp/core/fsfromfsviacs/lib.ml rename to tests/fsharp/core/fsfromfsviacs/lib.fs index f40253dc6340..ceb7bc8fbaea 100644 --- a/tests/fsharp/core/fsfromfsviacs/lib.ml +++ b/tests/fsharp/core/fsfromfsviacs/lib.fs @@ -1,4 +1,4 @@ - +module Lib (* An F# library which we use in a C# library, where we in turn use both the F# component and the C# library together from F# *) type recd1 = { recd1field1: int } @@ -44,3 +44,73 @@ let tup4 = (2,3,4,5) + +module StructUnionsTests = + + [] + type U0 = U0 + + let f0 x = match x with U0 -> 1 + + let v0 = f0 U0 + + [] + type U1 = U1 of int + + let f1 x = match x with U1(x) -> x + x + + let v1 = f1 (U1(3)) + + [] + type U2 = U2 of int * int + + let f2 x = match x with U2(x,y) -> x + y + + let v2 = f2 (U2(3,4)) + + [] + type Ok3 = Ok3 of int * Ok3 list + +/// Nesting structs inside struct unions means taking the address of things during pattern matching +module NestedStructUnionsTests = + + [] + type U1 = U1 of System.DateTime * string + + [] + type U2 = U2 of U1 * U1 + + + let testPattern1(u2:U2) = + match u2 with + | U2(u1a,u1b) -> + match u1a, u1b with + | U1(dt1,s1), U1(dt2,s2) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern2(u2:U2) = + match u2 with + | U2(U1(dt1,s1),U1(dt2,s2)) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern3(u2:U2) = + match u2 with + | U2(U1(dt1,"a"),U1(dt2,"b")) -> (dt1 = dt2) + + + let testPattern1mut(u2:U2) = + let mutable u2 = u2 + match u2 with + | U2(u1a,u1b) -> + match u1a, u1b with + | U1(dt1,s1), U1(dt2,s2) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern2mut(u2:U2) = + let mutable u2 = u2 + match u2 with + | U2(U1(dt1,s1),U1(dt2,s2)) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern3mut(u2:U2) = + let mutable u2 = u2 + match u2 with + | U2(U1(dt1,"a"),U1(dt2,"b")) -> (dt1 = dt2) + + diff --git a/tests/fsharp/core/fsfromfsviacs/lib2.cs b/tests/fsharp/core/fsfromfsviacs/lib2.cs index c86e38e7ac6e..969347a49f77 100644 --- a/tests/fsharp/core/fsfromfsviacs/lib2.cs +++ b/tests/fsharp/core/fsfromfsviacs/lib2.cs @@ -32,6 +32,10 @@ public class Lib2 public static FSharpRef ri1 = new FSharpRef(3); public static FSharpRef rr1 = new FSharpRef(r1); + public static Lib.StructUnionsTests.U0 u0 = Lib.StructUnionsTests.U0.U0; + public static Lib.StructUnionsTests.U1 u1 = Lib.StructUnionsTests.U1.NewU1(3); + public static Lib.StructUnionsTests.U2 u2 = Lib.StructUnionsTests.U2.NewU2(3,4); + static Lib2() { r3.recd3field3 = r3; } } diff --git a/tests/fsharp/core/fsfromfsviacs/test.fsx b/tests/fsharp/core/fsfromfsviacs/test.fsx index 742b0f284a5c..2c0f1652a0cb 100644 --- a/tests/fsharp/core/fsfromfsviacs/test.fsx +++ b/tests/fsharp/core/fsfromfsviacs/test.fsx @@ -27,7 +27,71 @@ let _ = test "fejio2dw" (Lib2.or1 = Some r1) let _ = test "fejio2dw" (Lib2.ri1 = ref 3) let _ = test "fejio2dw" (Lib2.rr1 = ref r1) +let _ = test "structunion3948" (Lib2.u0 = Lib.StructUnionsTests.U0) +let _ = test "structunion3949" (Lib2.u1 = Lib.StructUnionsTests.U1(3)) +let _ = test "structunion3949" (Lib2.u2 = Lib.StructUnionsTests.U2(3,4)) + +let _ = test "structunion3948" (compare Lib2.u0 Lib.StructUnionsTests.U0 = 0) +let _ = test "structunion3949" (compare Lib2.u1 (Lib.StructUnionsTests.U1(3)) = 0) +let _ = test "structunion394a" (compare Lib2.u1 (Lib.StructUnionsTests.U1(4)) = -1) +let _ = test "structunion394b" (compare Lib2.u1 (Lib.StructUnionsTests.U1(2)) = 1) +let dt = System.DateTime.Now +let u1a = Lib.NestedStructUnionsTests.U1(dt,"a") +let u1b = Lib.NestedStructUnionsTests.U1(dt,"b") +let u2 = Lib.NestedStructUnionsTests.U2(u1a,u1b) +let _ = test "structunion394b11" (Lib.NestedStructUnionsTests.testPattern1(u2)) +let _ = test "structunion394b22" (Lib.NestedStructUnionsTests.testPattern2(u2)) +let _ = test "structunion394b33" (Lib.NestedStructUnionsTests.testPattern3(u2)) +let _ = test "structunion394b14" (Lib.NestedStructUnionsTests.testPattern1mut(u2)) +let _ = test "structunion394b25" (Lib.NestedStructUnionsTests.testPattern2mut(u2)) +let _ = test "structunion394b36" (Lib.NestedStructUnionsTests.testPattern3mut(u2)) + + +module NestedStructPatternMatchingAcrossAssemblyBoundaries = + open Lib.NestedStructUnionsTests + + let testPattern1(u2:U2) = + match u2 with + | U2(u1a,u1b) -> + match u1a, u1b with + | U1(dt1,s1), U1(dt2,s2) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern2(u2:U2) = + match u2 with + | U2(U1(dt1,s1),U1(dt2,s2)) -> (dt1 = dt2) + + let testPattern3(u2:U2) = + match u2 with + | U2(U1(dt1,"a"),U1(dt2,"b")) -> (dt1 = dt2) + + let testPattern1mut(u2:U2) = + let mutable u2 = u2 + match u2 with + | U2(u1a,u1b) -> + match u1a, u1b with + | U1(dt1,s1), U1(dt2,s2) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern2mut(u2:U2) = + let mutable u2 = u2 + match u2 with + | U2(U1(dt1,s1),U1(dt2,s2)) -> (dt1 = dt2) && (s1 = "a") && (s2 = "b") + + let testPattern3mut(u2:U2) = + let mutable u2 = u2 + match u2 with + | U2(U1(dt1,"a"),U1(dt2,"b")) -> (dt1 = dt2) + + + let _ = test "structunion394b1a" (testPattern1(u2)) + let _ = test "structunion394b2b" (testPattern2(u2)) + let _ = test "structunion394b3c" (testPattern3(u2)) + + let _ = test "structunion394b1d" (testPattern1mut(u2)) + let _ = test "structunion394b2e" (testPattern2mut(u2)) + let _ = test "structunion394b3f" (testPattern3mut(u2)) + + (* public Lib.discr1_0 d10a = Lib.discr1_0.MkDiscr1_0_A(); public Lib.discr1_1 d11a = Lib.discr1_1.MkDiscr1_1_A(3); diff --git a/tests/fsharp/core/quotes/test.fsx b/tests/fsharp/core/quotes/test.fsx index 2c45e996577d..2ad7e1386a4b 100644 --- a/tests/fsharp/core/quotes/test.fsx +++ b/tests/fsharp/core/quotes/test.fsx @@ -1610,93 +1610,38 @@ module MoreQuotationsTests = let _ = <@@ v2.Int32ExtensionMethod5 @@> |> printfn "quote = %A" -module QuotationConstructionTests = - let arr = [| 1;2;3;4;5 |] - let f : int -> int = printfn "hello"; (fun x -> x) - let f2 : int * int -> int -> int = printfn "hello"; (fun (x,y) z -> x + y + z) - let F (x:int) = x - let F2 (x:int,y:int) (z:int) = x + y + z - - type Foo () = - member t.Item with get (index:int) = 1 - and set (index:int) (value:int) = () - - let ctorof q = match q with Patterns.NewObject(cinfo,_) -> cinfo | _ -> failwith "ctorof" - let methodof q = match q with DerivedPatterns.Lambdas(_,Patterns.Call(_,minfo,_)) -> minfo | _ -> failwith "methodof" - let fieldof q = match q with Patterns.FieldGet(_,finfo) -> finfo | _ -> failwith "fieldof" - let ucaseof q = match q with Patterns.NewUnionCase(ucinfo,_) -> ucinfo | _ -> failwith "ucaseof" - let getof q = match q with Patterns.PropertyGet(_,pinfo,_) -> pinfo | _ -> failwith "getof" - let setof q = match q with Patterns.PropertySet(_,pinfo,_,_) -> pinfo | _ -> failwith "setof" - check "vcknwwe01" (match Expr.AddressOf <@@ arr.[3] @@> with AddressOf(expr) -> expr = <@@ arr.[3] @@> | _ -> false) true - check "vcknwwe02" (match Expr.AddressSet (Expr.AddressOf <@@ arr.[3] @@>, <@@ 4 @@>) with AddressSet(AddressOf(expr),v) -> expr = <@@ arr.[3] @@> && v = <@@ 4 @@> | _ -> false) true - check "vcknwwe03" (match Expr.Application(<@@ f @@>,<@@ 5 @@>) with Application(f1,x) -> f1 = <@@ f @@> && x = <@@ 5 @@> | _ -> false) true - check "vcknwwe04" (match Expr.Applications(<@@ f @@>,[[ <@@ 5 @@> ]]) with Applications(f1,[[x]]) -> f1 = <@@ f @@> && x = <@@ 5 @@> | _ -> false) true - check "vcknwwe05" (match Expr.Applications(<@@ f2 @@>,[[ <@@ 5 @@>;<@@ 6 @@> ]; [ <@@ 7 @@> ]]) with Applications(f1,[[x;y];[z]]) -> f1 = <@@ f2 @@> && x = <@@ 5 @@> && y = <@@ 6 @@> && z = <@@ 7 @@> | _ -> false) true - check "vcknwwe06" (match Expr.Call(methodof <@@ F2 @@>,[ <@@ 5 @@>;<@@ 6 @@>; <@@ 7 @@> ]) with Call(None,minfo,[x;y;z]) -> minfo = methodof <@@ F2 @@> && x = <@@ 5 @@> && y = <@@ 6 @@> && z = <@@ 7 @@> | _ -> false) true - check "vcknwwe07" (Expr.Cast(<@@ 5 @@>) : Expr) (<@ 5 @>) - check "vcknwwe08" (try let _ = Expr.Cast(<@@ 5 @@>) : Expr in false with :? System.ArgumentException -> true) true - check "vcknwwe09" (match Expr.Coerce(<@@ 5 @@>, typeof) with Coerce(q,ty) -> ty = typeof && q = <@@ 5 @@> | _ -> false) true - check "vcknwwe0q" (match Expr.DefaultValue(typeof) with DefaultValue(ty) -> ty = typeof | _ -> false) true - check "vcknwwe0w" (match Expr.FieldGet(typeof.GetField("MaxValue")) with FieldGet(None,finfo) -> finfo = typeof.GetField("MaxValue") | _ -> false) true - check "vcknwwe0e" (match Expr.FieldSet(typeof.GetField("MaxValue"),<@@ 1 @@>) with FieldSet(None,finfo,v) -> finfo = typeof.GetField("MaxValue") && v = <@@ 1 @@> | _ -> false) true - check "vcknwwe0r" (match Expr.ForIntegerRangeLoop(Var.Global("i",typeof),<@@ 1 @@>,<@@ 10 @@>,<@@ () @@>) with ForIntegerRangeLoop(v,start,finish,body) -> v = Var.Global("i",typeof) && start = <@@ 1 @@> && finish = <@@ 10 @@> && body = <@@ () @@> | _ -> false) true - check "vcknwwe0t" (match Expr.GlobalVar("i") : Expr with Var(v) -> v = Var.Global("i",typeof) | _ -> false) true - check "vcknwwe0y" (match Expr.IfThenElse(<@@ true @@>,<@@ 1 @@>,<@@ 2 @@>) with IfThenElse(gd,t,e) -> gd = <@@ true @@> && t = <@@ 1 @@> && e = <@@ 2 @@> | _ -> false) true - check "vcknwwe0u" (match Expr.Lambda(Var.Global("i",typeof), <@@ 2 @@>) with Lambda(v,b) -> v = Var.Global("i",typeof) && b = <@@ 2 @@> | _ -> false) true - check "vcknwwe0i" (match Expr.Let(Var.Global("i",typeof), <@@ 2 @@>, <@@ 3 @@>) with Let(v,e,b) -> v = Var.Global("i",typeof) && e = <@@ 2 @@> && b = <@@ 3 @@> | _ -> false) true - check "vcknwwe0o" (match Expr.LetRecursive([(Var.Global("i",typeof), <@@ 2 @@>)], <@@ 3 @@>) with LetRecursive([(v,e)],b) -> v = Var.Global("i",typeof) && e = <@@ 2 @@> && b = <@@ 3 @@> | _ -> false) true - check "vcknwwe0p" (match Expr.LetRecursive([(Var.Global("i",typeof), <@@ 2 @@>);(Var.Global("j",typeof), <@@ 3 @@>)], <@@ 3 @@>) with LetRecursive([(v1,e1);(v2,e2)],b) -> v1 = Var.Global("i",typeof) && v2 = Var.Global("j",typeof) && e1 = <@@ 2 @@> && e2 = <@@ 3 @@> && b = <@@ 3 @@> | _ -> false) true - check "vcknwwe0a" (Expr.NewArray(typeof,[ <@@ 1 @@>; <@@ 2 @@> ])) <@@ [| 1;2 |] @@> - check "vcknwwe0s" (match Expr.NewDelegate(typeof>,[ Var.Global("i",typeof) ], <@@ () @@>) with NewDelegate(ty,[v],e) -> ty = typeof> && v = Var.Global("i",typeof) && e = <@@ () @@> | _ -> false) true - check "vcknwwe0d" (match Expr.NewObject(ctorof <@@ new obj() @@> ,[ ]) with NewObject(ty,[]) -> ty = ctorof <@@ new obj() @@> | _ -> false) true - check "vcknwwe0f" (match Expr.NewObject(ctorof <@@ new System.String('a',3) @@> ,[ <@@ 'b' @@>; <@@ 4 @@>]) with NewObject(ty,[x;y]) -> ty = ctorof <@@ new string('a',3) @@> && x = <@@ 'b' @@> && y = <@@ 4 @@> | _ -> false) true - check "vcknwwe0g" (Expr.NewRecord(typeof ,[ <@@ 4 @@> ])) <@@ { contents = 4 } @@> - check "vcknwwe0h" (try let _ = Expr.NewTuple([]) in false with :? System.ArgumentException -> true) true - check "vcknwwe0j" (try let _ = Expr.NewTuple([ <@@ 1 @@> ]) in true with :? System.ArgumentException -> false) true - check "vcknwwe0k" (match Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>]) with NewTuple([x;y]) -> x = <@@ 'b' @@> && y = <@@ 4 @@> | _ -> false) true - check "vcknwwe0l" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>])) <@@ ('b',4) @@> - check "vcknwwe0z" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>])) <@@ ('b',4,5) @@> - check "vcknwwe0x" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>; <@@ 6 @@>])) <@@ ('b',4,5,6) @@> - check "vcknwwe0c" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>; <@@ 6 @@>; <@@ 7 @@>])) <@@ ('b',4,5,6,7) @@> - check "vcknwwe0v" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>; <@@ 6 @@>; <@@ 7 @@>; <@@ 8 @@>])) <@@ ('b',4,5,6,7,8) @@> - check "vcknwwe0b" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>; <@@ 6 @@>; <@@ 7 @@>; <@@ 8 @@>; <@@ 9 @@>])) <@@ ('b',4,5,6,7,8,9) @@> - check "vcknwwe0n" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>; <@@ 6 @@>; <@@ 7 @@>; <@@ 8 @@>; <@@ 9 @@>; <@@ 10 @@>])) <@@ ('b',4,5,6,7,8,9,10) @@> - check "vcknwwe0m" (Expr.NewTuple([ <@@ 'b' @@>; <@@ 4 @@>; <@@ 5 @@>; <@@ 6 @@>; <@@ 7 @@>; <@@ 8 @@>; <@@ 9 @@>; <@@ 10 @@>])) <@@ ('b',4,5,6,7,8,9,10) @@> - check "vcknwwe011" (Expr.NewUnionCase(ucaseof <@@ Some(3) @@>,[ <@@ 4 @@> ])) <@@ Some(4) @@> - check "vcknwwe022" (Expr.NewUnionCase(ucaseof <@@ None @@>,[ ])) <@@ None @@> - check "vcknwwe033" (try let _ = Expr.NewUnionCase(ucaseof <@@ Some(3) @@>,[ ]) in false with :? ArgumentException -> true) true - check "vcknwwe044" (try let _ = Expr.NewUnionCase(ucaseof <@@ None @@>,[ <@@ 1 @@> ]) in false with :? ArgumentException -> true) true - check "vcknwwe055" (Expr.PropertyGet(getof <@@ System.DateTime.Now @@>,[ ])) <@@ System.DateTime.Now @@> - check "vcknwwe066" (try let _ = Expr.PropertyGet(getof <@@ System.DateTime.Now @@>,[ <@@ 1 @@> ]) in false with :? ArgumentException -> true) true - check "vcknwwe077" (Expr.PropertyGet(<@@ "3" @@>, getof <@@ "1".Length @@>)) <@@ "3".Length @@> - check "vcknwwe088" (Expr.PropertyGet(<@@ "3" @@>, getof <@@ "1".Length @@>,[ ])) <@@ "3".Length @@> - #if Portable - #else - check "vcknwwe099" (Expr.PropertySet(<@@ (new System.Windows.Forms.Form()) @@>, setof <@@ (new System.Windows.Forms.Form()).Text <- "2" @@>, <@@ "3" @@> )) <@@ (new System.Windows.Forms.Form()).Text <- "3" @@> - #endif - check "vcknwwe099" (Expr.PropertySet(<@@ (new Foo()) @@>, setof <@@ (new Foo()).[3] <- 1 @@>, <@@ 2 @@> , [ <@@ 3 @@> ] )) <@@ (new Foo()).[3] <- 2 @@> -#if FSHARP_CORE_31 -#else - check "vcknwwe0qq1" (Expr.QuoteRaw(<@ "1" @>)) <@@ <@@ "1" @@> @@> - check "vcknwwe0qq2" (Expr.QuoteRaw(<@@ "1" @@>)) <@@ <@@ "1" @@> @@> - check "vcknwwe0qq3" (Expr.QuoteTyped(<@ "1" @>)) <@@ <@ "1" @> @@> - check "vcknwwe0qq4" (Expr.QuoteTyped(<@@ "1" @@>)) <@@ <@ "1" @> @@> -#endif - check "vcknwwe0ww" (Expr.Sequential(<@@ () @@>, <@@ 1 @@>)) <@@ (); 1 @@> - check "vcknwwe0ee" (Expr.TryFinally(<@@ 1 @@>, <@@ () @@>)) <@@ try 1 finally () @@> - check "vcknwwe0rr" (match Expr.TryWith(<@@ 1 @@>, Var.Global("e1",typeof), <@@ 1 @@>, Var.Global("e2",typeof), <@@ 2 @@>) with TryWith(b,v1,ef,v2,eh) -> b = <@@ 1 @@> && eh = <@@ 2 @@> && ef = <@@ 1 @@> && v1 = Var.Global("e1",typeof) && v2 = Var.Global("e2",typeof)| _ -> false) true - check "vcknwwe0tt" (match Expr.TupleGet(<@@ (1,2) @@>, 0) with TupleGet(b,n) -> b = <@@ (1,2) @@> && n = 0 | _ -> false) true - check "vcknwwe0yy" (match Expr.TupleGet(<@@ (1,2) @@>, 1) with TupleGet(b,n) -> b = <@@ (1,2) @@> && n = 1 | _ -> false) true - check "vcknwwe0uu" (try let _ = Expr.TupleGet(<@@ (1,2) @@>, 2) in false with :? ArgumentException -> true) true - check "vcknwwe0ii" (try let _ = Expr.TupleGet(<@@ (1,2) @@>, -1) in false with :? ArgumentException -> true) true - for i = 0 to 7 do - check "vcknwwe0oo" (match Expr.TupleGet(<@@ (1,2,3,4,5,6,7,8) @@>, i) with TupleGet(b,n) -> b = <@@ (1,2,3,4,5,6,7,8) @@> && n = i | _ -> false) true - check "vcknwwe0pp" (match Expr.TypeTest(<@@ new obj() @@>, typeof) with TypeTest(e,ty) -> e = <@@ new obj() @@> && ty = typeof | _ -> false) true - check "vcknwwe0aa" (match Expr.UnionCaseTest(<@@ [] : int list @@>, ucaseof <@@ [] : int list @@> ) with UnionCaseTest(e,uc) -> e = <@@ [] : int list @@> && uc = ucaseof <@@ [] : int list @@> | _ -> false) true - check "vcknwwe0ss" (Expr.Value(3)) <@@ 3 @@> - check "vcknwwe0dd" (match Expr.Var(Var.Global("i",typeof)) with Var(v) -> v = Var.Global("i",typeof) | _ -> false) true - check "vcknwwe0ff" (match Expr.VarSet(Var.Global("i",typeof), <@@ 4 @@>) with VarSet(v,q) -> v = Var.Global("i",typeof) && q = <@@ 4 @@> | _ -> false) true - check "vcknwwe0gg" (match Expr.WhileLoop(<@@ true @@>, <@@ () @@>) with WhileLoop(g,b) -> g = <@@ true @@> && b = <@@ () @@> | _ -> false) true +module QuotationStructUnionTests = + + [] + type T = | A of int + + test "check NewUnionCase" (<@ A(1) @> |> (function NewUnionCase(unionCase,args) -> true | _ -> false)) + + [] + let foo v = match v with | A(1) -> 0 | _ -> 1 + + test "check TryGetReflectedDefinition (local f)" + ((<@ foo (A(1)) @> |> (function Call(None,minfo,args) -> Quotations.Expr.TryGetReflectedDefinition(minfo).IsSome | _ -> false))) + + [] + let test3297327 v = match v with | A(1) -> 0 | _ -> 1 + + test "check TryGetReflectedDefinition (local f)" + ((<@ foo (A(1)) @> |> (function Call(None,minfo,args) -> Quotations.Expr.TryGetReflectedDefinition(minfo).IsSome | _ -> false))) + + + [] + type T2 = + | A1 of int * int + + test "check NewUnionCase" (<@ A1(1,2) @> |> (function NewUnionCase(unionCase,[ Int32 1; Int32 2 ]) -> true | _ -> false)) + + //[] + //type T3 = + // | A1 of int * int + // + //test "check NewUnionCase" (<@ A1(1,2) @> |> (function NewUnionCase(unionCase,[ Int32 1; Int32 2 ]) -> true | _ -> false)) + module EqualityOnExprDoesntFail = let q = <@ 1 @> diff --git a/tests/fsharp/core/tests_core.fs b/tests/fsharp/core/tests_core.fs index 4e2d891b1d2b..68ec3baeb855 100644 --- a/tests/fsharp/core/tests_core.fs +++ b/tests/fsharp/core/tests_core.fs @@ -266,8 +266,8 @@ module FsFromCs = let csc = Printf.ksprintf (Commands.csc exec cfg.CSC) let fsc_flags = cfg.fsc_flags - // "%FSC%" %fsc_flags% -a --doc:lib.xml -o:lib.dll -g lib.ml - do! fsc "%s -a --doc:lib.xml -o:lib.dll -g" fsc_flags ["lib.ml"] + // "%FSC%" %fsc_flags% -a --doc:lib.xml -o:lib.dll -g lib.fs + do! fsc "%s -a --doc:lib.xml -o:lib.dll -g" fsc_flags ["lib.fs"] // "%PEVERIFY%" lib.dll do! peverify "lib.dll" @@ -275,8 +275,8 @@ module FsFromCs = // %CSC% /nologo /r:"%FSCOREDLLPATH%" /r:System.Core.dll /r:lib.dll /out:test.exe test.cs do! csc """/nologo /r:"%s" /r:System.Core.dll /r:lib.dll /out:test.exe""" cfg.FSCOREDLLPATH ["test.cs"] - // "%FSC%" %fsc_flags% -a --doc:lib--optimize.xml -o:lib--optimize.dll -g lib.ml - do! fsc """%s -a --doc:lib--optimize.xml -o:lib--optimize.dll -g""" fsc_flags ["lib.ml"] + // "%FSC%" %fsc_flags% -a --doc:lib--optimize.xml -o:lib--optimize.dll -g lib.fs + do! fsc """%s -a --doc:lib--optimize.xml -o:lib--optimize.dll -g""" fsc_flags ["lib.fs"] // "%PEVERIFY%" lib--optimize.dll do! peverify "lib--optimize.dll" @@ -316,8 +316,8 @@ module FsFromFsViaCs = let csc = Printf.ksprintf (Commands.csc exec cfg.CSC) let fsc_flags = cfg.fsc_flags - // "%FSC%" %fsc_flags% -a -o:lib.dll -g lib.ml - do! fsc "%s -a -o:lib.dll -g" fsc_flags ["lib.ml"] + // "%FSC%" %fsc_flags% -a -o:lib.dll -g lib.fs + do! fsc "%s -a -o:lib.dll -g" fsc_flags ["lib.fs"] // "%PEVERIFY%" lib.dll do! peverify "lib.dll" From b7eb48eedb5c38bde8d7d47ef61954b9b0b00021 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 16 Jun 2016 17:51:47 +0100 Subject: [PATCH 08/12] fix unit test build --- .../FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs index 73f548920dc9..517e69a92007 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/DiscrimantedUnionType.fs @@ -239,7 +239,7 @@ let [] ``can properly construct a struct union using FSharpValue.MakeUnion Assert.IsTrue (structUnion.GetType().IsValueType) - let fieldVals = Microsoft.FSharp.Reflection.FSharpValue.GetUnionFields(structUnion, typeof) + let _uc, fieldVals = Microsoft.FSharp.Reflection.FSharpValue.GetUnionFields(structUnion, typeof) Assert.AreEqual (2, fieldVals.Length) From cacc03f51f7ee043d3f5d60d04f687766634995e Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 17 Jun 2016 00:01:04 +0100 Subject: [PATCH 09/12] allow elimination of more copy-of-struct locals --- src/fsharp/TastOps.fs | 25 ++++++++++++++----------- src/fsharp/TastOps.fsi | 2 +- src/fsharp/TypeChecker.fs | 2 +- 3 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index a1e9a6717f21..969265ac4848 100755 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -5041,14 +5041,14 @@ and remarkBind m (TBind(v,repr,_)) = //-------------------------------------------------------------------------- let isRecdOrStructFieldAllocObservable (f:RecdField) = not f.IsStatic && f.IsMutable -let ucaseAllocObservable (uc:UnionCase) = uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldAllocObservable -let isUnionCaseAllocObservable (uc:UnionCaseRef) = uc.UnionCase |> ucaseAllocObservable +let isUnionCaseAllocObservable (uc:UnionCase) = uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldAllocObservable +let isUnionCaseRefAllocObservable (uc:UnionCaseRef) = uc.UnionCase |> isUnionCaseAllocObservable let isRecdOrUnionOrStructTyconAllocObservable (_g:TcGlobals) (tycon:Tycon) = - if tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + if tycon.IsUnionTycon then + tycon.UnionCasesArray |> Array.exists isUnionCaseAllocObservable + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then tycon.AllFieldsArray |> Array.exists isRecdOrStructFieldAllocObservable - elif tycon.IsUnionTycon then - tycon.UnionCasesArray |> Array.exists ucaseAllocObservable else false @@ -5374,7 +5374,7 @@ let mkAndSimplifyMatch spBind exprm matchm ty tree targets = type Mutates = DefinitelyMutates | PossiblyMutates | NeverMutates exception DefensiveCopyWarning of string * range -let isRecdOrStuctTyImmutable g ty = +let isRecdOrStructTyImmutable g ty = match tryDestAppTy g ty with | None -> false | Some tcref -> @@ -5393,7 +5393,7 @@ let isRecdOrStuctTyImmutable g ty = // let g1 = A.G(1) // (fun () -> g1.x1) // -// Note: isRecdOrStuctTyImmutable implies PossiblyMutates or NeverMutates +// Note: isRecdOrStructTyImmutable implies PossiblyMutates or NeverMutates // // We only do this for true local or closure fields because we can't take adddresses of immutable static // fields across assemblies. @@ -5404,7 +5404,7 @@ let CanTakeAddressOfImmutableVal g (v:ValRef) mut = not v.IsMemberOrModuleBinding && (match mut with | NeverMutates -> true - | PossiblyMutates -> isRecdOrStuctTyImmutable g v.Type + | PossiblyMutates -> isRecdOrStructTyImmutable g v.Type | DefinitelyMutates -> false) let MustTakeAddressOfVal g (v:ValRef) = @@ -5423,13 +5423,13 @@ let CanTakeAddressOfRecdFieldRef g (rfref: RecdFieldRef) mut tinst = mut <> DefinitelyMutates && // We only do this if the field is defined in this assembly because we can't take adddresses across assemblies for immutable fields entityRefInThisAssembly g.compilingFslib rfref.TyconRef && - isRecdOrStuctTyImmutable g (actualTyOfRecdFieldRef rfref tinst) + isRecdOrStructTyImmutable g (actualTyOfRecdFieldRef rfref tinst) let CanTakeAddressOfUnionFieldRef g (uref: UnionCaseRef) mut tinst cidx = mut <> DefinitelyMutates && // We only do this if the field is defined in this assembly because we can't take adddresses across assemblies for immutable fields entityRefInThisAssembly g.compilingFslib uref.TyconRef && - isRecdOrStuctTyImmutable g (actualTyOfUnionFieldRef uref cidx tinst) + isRecdOrStructTyImmutable g (actualTyOfUnionFieldRef uref cidx tinst) let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = @@ -5511,7 +5511,10 @@ let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress errorR(Error(FSComp.SR.tastInvalidMutationOfConstant(),m)); | PossiblyMutates -> warning(DefensiveCopyWarning(FSComp.SR.tastValueHasBeenCopied(),m)); - let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" ty + let tmp,_ = + match mut with + | NeverMutates -> mkCompGenLocal m "copyOfStruct" ty + | _ -> mkMutableCompGenLocal m "copyOfStruct" ty Some (tmp,e), (mkValAddr m (mkLocalValRef tmp)) let mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 4eefb78177a4..e99cabd7c147 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -1046,7 +1046,7 @@ val TypeHasDefaultValue : TcGlobals -> range -> TType -> bool val isAbstractTycon : Tycon -> bool -val isUnionCaseAllocObservable : UnionCaseRef -> bool +val isUnionCaseRefAllocObservable : UnionCaseRef -> bool val isRecdOrUnionOrStructTyconRefAllocObservable : TcGlobals -> TyconRef -> bool val isExnAllocObservable : TyconRef -> bool val isUnionCaseFieldMutable : TcGlobals -> UnionCaseRef -> int -> bool diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 30085eac622b..de38c64e5311 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2037,7 +2037,7 @@ module GeneralizationHelpers = | Expr.Op(op,_,args,_) -> match op with | TOp.Tuple -> true - | TOp.UnionCase uc -> not (isUnionCaseAllocObservable uc) + | TOp.UnionCase uc -> not (isUnionCaseRefAllocObservable uc) | TOp.Recd(ctorInfo,tcref) -> match ctorInfo with | RecdExpr -> not (isRecdOrUnionOrStructTyconRefAllocObservable g tcref) From 0e72bebcf32127089d5c80a6fbb63ef703c5da46 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 17 Jun 2016 00:17:08 +0100 Subject: [PATCH 10/12] add new test for struct union codegen --- .../Optimizations/Inlining/StructUnion01.fs | 39 + .../Inlining/StructUnion01.il.bsl | 725 ++++++++++++++++++ .../Source/Optimizations/Inlining/env.lst | 1 + 3 files changed, 765 insertions(+) create mode 100644 tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.fs create mode 100644 tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.il.bsl diff --git a/tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.fs b/tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.fs new file mode 100644 index 000000000000..d3e41ff4788f --- /dev/null +++ b/tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.fs @@ -0,0 +1,39 @@ +// #NoMono #CodeGen #Optimizations +module StructUnion01 + +[] +type U = U of int * int + +let g1 (U(a,b)) = a + b + +let g2 u = + let (U(a,b)) = u + a + b + +let g3 (x:U) = + match x with + | U(3,a) -> a + | U(a,b) -> a + b + +let g4 (x:U) (y: U) = + match x,y with + | U(3,a), U(5,b) -> a + b + | U(a,b), U(c,d) -> a + b + c + d + +let f1 (x:U byref) = + let (U(a,b)) = x + a + b + +let f2 (x:U byref) = + match x with + | U(a,b) -> a + b + +let f3 (x:U byref) = + match x with + | U(3,a) -> a + | U(a,b) -> a + b + +let f4 (x:U byref) (y: U byref) = + match x,y with + | U(3,a), U(5,b) -> a + b + | U(a,b), U(c,d) -> a + b + c + d diff --git a/tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.il.bsl b/tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.il.bsl new file mode 100644 index 000000000000..95df244b59b9 --- /dev/null +++ b/tests/fsharpqa/Source/Optimizations/Inlining/StructUnion01.il.bsl @@ -0,0 +1,725 @@ + +// Microsoft (R) .NET Framework IL Disassembler. Version 4.6.1055.0 +// Copyright (c) Microsoft Corporation. All rights reserved. + + + +// Metadata version: v4.0.30319 +.assembly extern mscorlib +{ + .publickeytoken = (B7 7A 5C 56 19 34 E0 89 ) // .z\V.4.. + .ver 4:0:0:0 +} +.assembly extern FSharp.Core +{ + .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: + .ver 4:4:1:0 +} +.assembly StructUnion01 +{ + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.FSharpInterfaceDataVersionAttribute::.ctor(int32, + int32, + int32) = ( 01 00 02 00 00 00 00 00 00 00 00 00 00 00 00 00 ) + .hash algorithm 0x00008004 + .ver 0:0:0:0 +} +.mresource public FSharpSignatureData.StructUnion01 +{ + // Offset: 0x00000000 Length: 0x0000088A +} +.mresource public FSharpOptimizationData.StructUnion01 +{ + // Offset: 0x00000890 Length: 0x00000421 +} +.module StructUnion01.dll +// MVID: {576332E3-D3E9-6B24-A745-0383E3326357} +.imagebase 0x00400000 +.file alignment 0x00000200 +.stackreserve 0x00100000 +.subsystem 0x0003 // WINDOWS_CUI +.corflags 0x00000001 // ILONLY +// Image base: 0x007C0000 + + +// =============== CLASS MEMBERS DECLARATION =================== + +.class public abstract auto ansi sealed StructUnion01 + extends [mscorlib]System.Object +{ + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) + .class auto autochar serializable sealed nested public beforefieldinit U + extends [mscorlib]System.ValueType + implements class [mscorlib]System.IEquatable`1, + [mscorlib]System.Collections.IStructuralEquatable, + class [mscorlib]System.IComparable`1, + [mscorlib]System.IComparable, + [mscorlib]System.Collections.IStructuralComparable + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.StructAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerDisplayAttribute::.ctor(string) = ( 01 00 15 7B 5F 5F 44 65 62 75 67 44 69 73 70 6C // ...{__DebugDispl + 61 79 28 29 2C 6E 71 7D 00 00 ) // ay(),nq}.. + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 01 00 00 00 00 00 ) + .field assembly int32 item1 + .custom instance void [mscorlib]System.Diagnostics.DebuggerBrowsableAttribute::.ctor(valuetype [mscorlib]System.Diagnostics.DebuggerBrowsableState) = ( 01 00 00 00 00 00 00 00 ) + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + .field assembly int32 item2 + .custom instance void [mscorlib]System.Diagnostics.DebuggerBrowsableAttribute::.ctor(valuetype [mscorlib]System.Diagnostics.DebuggerBrowsableState) = ( 01 00 00 00 00 00 00 00 ) + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + .method public static valuetype StructUnion01/U + NewU(int32 item1, + int32 item2) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags, + int32) = ( 01 00 08 00 00 00 00 00 00 00 00 00 ) + // Code size 8 (0x8) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: newobj instance void StructUnion01/U::.ctor(int32, + int32) + IL_0007: ret + } // end of method U::NewU + + .method assembly specialname rtspecialname + instance void .ctor(int32 item1, + int32 item2) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 15 (0xf) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: stfld int32 StructUnion01/U::item1 + IL_0007: ldarg.0 + IL_0008: ldarg.2 + IL_0009: stfld int32 StructUnion01/U::item2 + IL_000e: ret + } // end of method U::.ctor + + .method public hidebysig instance int32 + get_Item1() cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 7 (0x7) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: ldfld int32 StructUnion01/U::item1 + IL_0006: ret + } // end of method U::get_Item1 + + .method public hidebysig instance int32 + get_Item2() cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 7 (0x7) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: ldfld int32 StructUnion01/U::item2 + IL_0006: ret + } // end of method U::get_Item2 + + .method public hidebysig instance int32 + get_Tag() cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 4 (0x4) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: pop + IL_0002: ldc.i4.0 + IL_0003: ret + } // end of method U::get_Tag + + .method assembly hidebysig specialname + instance object __DebugDisplay() cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 27 (0x1b) + .maxstack 8 + IL_0000: ldstr "%+0.8A" + IL_0005: newobj instance void class [FSharp.Core]Microsoft.FSharp.Core.PrintfFormat`5,class [FSharp.Core]Microsoft.FSharp.Core.Unit,string,string,string>::.ctor(string) + IL_000a: call !!0 [FSharp.Core]Microsoft.FSharp.Core.ExtraTopLevelOperators::PrintFormatToString>(class [FSharp.Core]Microsoft.FSharp.Core.PrintfFormat`4) + IL_000f: ldarg.0 + IL_0010: ldobj StructUnion01/U + IL_0015: callvirt instance !1 class [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2::Invoke(!0) + IL_001a: ret + } // end of method U::__DebugDisplay + + .method public hidebysig virtual final + instance int32 CompareTo(valuetype StructUnion01/U obj) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 77 (0x4d) + .maxstack 4 + .locals init (int32 V_0, + class [mscorlib]System.Collections.IComparer V_1, + int32 V_2, + int32 V_3) + IL_0000: ldarg.0 + IL_0001: pop + IL_0002: call class [mscorlib]System.Collections.IComparer [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives::get_GenericComparer() + IL_0007: stloc.1 + IL_0008: ldarg.0 + IL_0009: ldfld int32 StructUnion01/U::item1 + IL_000e: stloc.2 + IL_000f: ldarg.1 + IL_0010: ldfld int32 StructUnion01/U::item1 + IL_0015: stloc.3 + IL_0016: ldloc.2 + IL_0017: ldloc.3 + IL_0018: bge.s IL_001d + + IL_001a: ldc.i4.m1 + IL_001b: br.s IL_0021 + + IL_001d: ldloc.2 + IL_001e: ldloc.3 + IL_001f: cgt + IL_0021: stloc.0 + IL_0022: ldloc.0 + IL_0023: ldc.i4.0 + IL_0024: bge.s IL_0028 + + IL_0026: ldloc.0 + IL_0027: ret + + IL_0028: ldloc.0 + IL_0029: ldc.i4.0 + IL_002a: ble.s IL_002e + + IL_002c: ldloc.0 + IL_002d: ret + + IL_002e: call class [mscorlib]System.Collections.IComparer [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives::get_GenericComparer() + IL_0033: stloc.1 + IL_0034: ldarg.0 + IL_0035: ldfld int32 StructUnion01/U::item2 + IL_003a: stloc.2 + IL_003b: ldarg.1 + IL_003c: ldfld int32 StructUnion01/U::item2 + IL_0041: stloc.3 + IL_0042: ldloc.2 + IL_0043: ldloc.3 + IL_0044: bge.s IL_0048 + + IL_0046: ldc.i4.m1 + IL_0047: ret + + IL_0048: ldloc.2 + IL_0049: ldloc.3 + IL_004a: cgt + IL_004c: ret + } // end of method U::CompareTo + + .method public hidebysig virtual final + instance int32 CompareTo(object obj) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 13 (0xd) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: ldarg.1 + IL_0002: unbox.any StructUnion01/U + IL_0007: call instance int32 StructUnion01/U::CompareTo(valuetype StructUnion01/U) + IL_000c: ret + } // end of method U::CompareTo + + .method public hidebysig virtual final + instance int32 CompareTo(object obj, + class [mscorlib]System.Collections.IComparer comp) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 81 (0x51) + .maxstack 4 + .locals init (valuetype StructUnion01/U V_0, + valuetype StructUnion01/U& V_1, + int32 V_2, + int32 V_3, + int32 V_4) + IL_0000: ldarg.1 + IL_0001: unbox.any StructUnion01/U + IL_0006: stloc.0 + IL_0007: ldloca.s V_0 + IL_0009: stloc.1 + IL_000a: ldarg.0 + IL_000b: pop + IL_000c: ldarg.0 + IL_000d: ldfld int32 StructUnion01/U::item1 + IL_0012: stloc.3 + IL_0013: ldloc.1 + IL_0014: ldfld int32 StructUnion01/U::item1 + IL_0019: stloc.s V_4 + IL_001b: ldloc.3 + IL_001c: ldloc.s V_4 + IL_001e: bge.s IL_0023 + + IL_0020: ldc.i4.m1 + IL_0021: br.s IL_0028 + + IL_0023: ldloc.3 + IL_0024: ldloc.s V_4 + IL_0026: cgt + IL_0028: stloc.2 + IL_0029: ldloc.2 + IL_002a: ldc.i4.0 + IL_002b: bge.s IL_002f + + IL_002d: ldloc.2 + IL_002e: ret + + IL_002f: ldloc.2 + IL_0030: ldc.i4.0 + IL_0031: ble.s IL_0035 + + IL_0033: ldloc.2 + IL_0034: ret + + IL_0035: ldarg.0 + IL_0036: ldfld int32 StructUnion01/U::item2 + IL_003b: stloc.3 + IL_003c: ldloc.1 + IL_003d: ldfld int32 StructUnion01/U::item2 + IL_0042: stloc.s V_4 + IL_0044: ldloc.3 + IL_0045: ldloc.s V_4 + IL_0047: bge.s IL_004b + + IL_0049: ldc.i4.m1 + IL_004a: ret + + IL_004b: ldloc.3 + IL_004c: ldloc.s V_4 + IL_004e: cgt + IL_0050: ret + } // end of method U::CompareTo + + .method public hidebysig virtual final + instance int32 GetHashCode(class [mscorlib]System.Collections.IEqualityComparer comp) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 50 (0x32) + .maxstack 7 + .locals init (int32 V_0) + IL_0000: ldc.i4.0 + IL_0001: stloc.0 + IL_0002: ldarg.0 + IL_0003: pop + IL_0004: ldc.i4.0 + IL_0005: stloc.0 + IL_0006: ldc.i4 0x9e3779b9 + IL_000b: ldarg.0 + IL_000c: ldfld int32 StructUnion01/U::item2 + IL_0011: ldloc.0 + IL_0012: ldc.i4.6 + IL_0013: shl + IL_0014: ldloc.0 + IL_0015: ldc.i4.2 + IL_0016: shr + IL_0017: add + IL_0018: add + IL_0019: add + IL_001a: stloc.0 + IL_001b: ldc.i4 0x9e3779b9 + IL_0020: ldarg.0 + IL_0021: ldfld int32 StructUnion01/U::item1 + IL_0026: ldloc.0 + IL_0027: ldc.i4.6 + IL_0028: shl + IL_0029: ldloc.0 + IL_002a: ldc.i4.2 + IL_002b: shr + IL_002c: add + IL_002d: add + IL_002e: add + IL_002f: stloc.0 + IL_0030: ldloc.0 + IL_0031: ret + } // end of method U::GetHashCode + + .method public hidebysig virtual final + instance int32 GetHashCode() cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 12 (0xc) + .maxstack 8 + IL_0000: ldarg.0 + IL_0001: call class [mscorlib]System.Collections.IEqualityComparer [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives::get_GenericEqualityComparer() + IL_0006: call instance int32 StructUnion01/U::GetHashCode(class [mscorlib]System.Collections.IEqualityComparer) + IL_000b: ret + } // end of method U::GetHashCode + + .method public hidebysig virtual final + instance bool Equals(object obj, + class [mscorlib]System.Collections.IEqualityComparer comp) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 53 (0x35) + .maxstack 4 + .locals init (valuetype StructUnion01/U V_0, + valuetype StructUnion01/U& V_1) + IL_0000: ldarg.1 + IL_0001: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) + IL_0006: brtrue.s IL_000a + + IL_0008: ldc.i4.0 + IL_0009: ret + + IL_000a: ldarg.1 + IL_000b: unbox.any StructUnion01/U + IL_0010: stloc.0 + IL_0011: ldloca.s V_0 + IL_0013: stloc.1 + IL_0014: ldarg.0 + IL_0015: pop + IL_0016: ldarg.0 + IL_0017: ldfld int32 StructUnion01/U::item1 + IL_001c: ldloc.1 + IL_001d: ldfld int32 StructUnion01/U::item1 + IL_0022: bne.un.s IL_0033 + + IL_0024: ldarg.0 + IL_0025: ldfld int32 StructUnion01/U::item2 + IL_002a: ldloc.1 + IL_002b: ldfld int32 StructUnion01/U::item2 + IL_0030: ceq + IL_0032: ret + + IL_0033: ldc.i4.0 + IL_0034: ret + } // end of method U::Equals + + .method public hidebysig virtual final + instance bool Equals(valuetype StructUnion01/U obj) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 36 (0x24) + .maxstack 4 + .locals init (valuetype StructUnion01/U& V_0) + IL_0000: ldarga.s obj + IL_0002: stloc.0 + IL_0003: ldarg.0 + IL_0004: pop + IL_0005: ldarg.0 + IL_0006: ldfld int32 StructUnion01/U::item1 + IL_000b: ldloc.0 + IL_000c: ldfld int32 StructUnion01/U::item1 + IL_0011: bne.un.s IL_0022 + + IL_0013: ldarg.0 + IL_0014: ldfld int32 StructUnion01/U::item2 + IL_0019: ldloc.0 + IL_001a: ldfld int32 StructUnion01/U::item2 + IL_001f: ceq + IL_0021: ret + + IL_0022: ldc.i4.0 + IL_0023: ret + } // end of method U::Equals + + .method public hidebysig virtual final + instance bool Equals(object obj) cil managed + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + // Code size 23 (0x17) + .maxstack 8 + IL_0000: ldarg.1 + IL_0001: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/IntrinsicFunctions::TypeTestGeneric(object) + IL_0006: brtrue.s IL_000a + + IL_0008: ldc.i4.0 + IL_0009: ret + + IL_000a: ldarg.0 + IL_000b: ldarg.1 + IL_000c: unbox.any StructUnion01/U + IL_0011: call instance bool StructUnion01/U::Equals(valuetype StructUnion01/U) + IL_0016: ret + } // end of method U::Equals + + .property instance int32 Tag() + { + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerBrowsableAttribute::.ctor(valuetype [mscorlib]System.Diagnostics.DebuggerBrowsableState) = ( 01 00 00 00 00 00 00 00 ) + .get instance int32 StructUnion01/U::get_Tag() + } // end of property U::Tag + .property instance int32 Item1() + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags, + int32, + int32) = ( 01 00 04 00 00 00 00 00 00 00 00 00 00 00 00 00 ) + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + .get instance int32 StructUnion01/U::get_Item1() + } // end of property U::Item1 + .property instance int32 Item2() + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags, + int32, + int32) = ( 01 00 04 00 00 00 00 00 00 00 01 00 00 00 00 00 ) + .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + .custom instance void [mscorlib]System.Diagnostics.DebuggerNonUserCodeAttribute::.ctor() = ( 01 00 00 00 ) + .get instance int32 StructUnion01/U::get_Item2() + } // end of property U::Item2 + } // end of class U + + .method public static int32 g1(valuetype StructUnion01/U _arg1) cil managed + { + // Code size 16 (0x10) + .maxstack 8 + IL_0000: ldarga.s _arg1 + IL_0002: ldfld int32 StructUnion01/U::item1 + IL_0007: ldarga.s _arg1 + IL_0009: ldfld int32 StructUnion01/U::item2 + IL_000e: add + IL_000f: ret + } // end of method StructUnion01::g1 + + .method public static int32 g2(valuetype StructUnion01/U u) cil managed + { + // Code size 16 (0x10) + .maxstack 8 + IL_0000: ldarga.s u + IL_0002: ldfld int32 StructUnion01/U::item1 + IL_0007: ldarga.s u + IL_0009: ldfld int32 StructUnion01/U::item2 + IL_000e: add + IL_000f: ret + } // end of method StructUnion01::g2 + + .method public static int32 g3(valuetype StructUnion01/U x) cil managed + { + // Code size 42 (0x2a) + .maxstack 8 + IL_0000: ldarga.s x + IL_0002: ldfld int32 StructUnion01/U::item1 + IL_0007: ldc.i4.3 + IL_0008: sub + IL_0009: switch ( + IL_0022) + IL_0012: ldarga.s x + IL_0014: ldfld int32 StructUnion01/U::item1 + IL_0019: ldarga.s x + IL_001b: ldfld int32 StructUnion01/U::item2 + IL_0020: add + IL_0021: ret + + IL_0022: ldarga.s x + IL_0024: ldfld int32 StructUnion01/U::item2 + IL_0029: ret + } // end of method StructUnion01::g3 + + .method public static int32 g4(valuetype StructUnion01/U x, + valuetype StructUnion01/U y) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationArgumentCountsAttribute::.ctor(int32[]) = ( 01 00 02 00 00 00 01 00 00 00 01 00 00 00 00 00 ) + // Code size 126 (0x7e) + .maxstack 6 + .locals init (int32 V_0, + int32 V_1, + int32 V_2, + int32 V_3) + IL_0000: ldarga.s x + IL_0002: ldfld int32 StructUnion01/U::item1 + IL_0007: ldc.i4.3 + IL_0008: sub + IL_0009: switch ( + IL_003a) + IL_0012: ldarga.s y + IL_0014: ldfld int32 StructUnion01/U::item2 + IL_0019: stloc.0 + IL_001a: ldarga.s y + IL_001c: ldfld int32 StructUnion01/U::item1 + IL_0021: stloc.1 + IL_0022: ldarga.s x + IL_0024: ldfld int32 StructUnion01/U::item2 + IL_0029: stloc.2 + IL_002a: ldarga.s x + IL_002c: ldfld int32 StructUnion01/U::item1 + IL_0031: stloc.3 + IL_0032: ldloc.3 + IL_0033: ldloc.2 + IL_0034: add + IL_0035: ldloc.1 + IL_0036: add + IL_0037: ldloc.0 + IL_0038: add + IL_0039: ret + + IL_003a: ldarga.s y + IL_003c: ldfld int32 StructUnion01/U::item1 + IL_0041: ldc.i4.5 + IL_0042: sub + IL_0043: switch ( + IL_006e) + IL_004c: ldarga.s y + IL_004e: ldfld int32 StructUnion01/U::item2 + IL_0053: ldarga.s y + IL_0055: ldfld int32 StructUnion01/U::item1 + IL_005a: ldarga.s x + IL_005c: ldfld int32 StructUnion01/U::item2 + IL_0061: ldarga.s x + IL_0063: ldfld int32 StructUnion01/U::item1 + IL_0068: stloc.3 + IL_0069: stloc.2 + IL_006a: stloc.1 + IL_006b: stloc.0 + IL_006c: br.s IL_0032 + + IL_006e: ldarga.s x + IL_0070: ldfld int32 StructUnion01/U::item2 + IL_0075: ldarga.s y + IL_0077: ldfld int32 StructUnion01/U::item2 + IL_007c: add + IL_007d: ret + } // end of method StructUnion01::g4 + + .method public static int32 f1(valuetype StructUnion01/U& x) cil managed + { + // Code size 23 (0x17) + .maxstack 4 + .locals init (valuetype StructUnion01/U V_0) + IL_0000: ldarg.0 + IL_0001: ldobj StructUnion01/U + IL_0006: stloc.0 + IL_0007: ldloca.s V_0 + IL_0009: ldfld int32 StructUnion01/U::item1 + IL_000e: ldloca.s V_0 + IL_0010: ldfld int32 StructUnion01/U::item2 + IL_0015: add + IL_0016: ret + } // end of method StructUnion01::f1 + + .method public static int32 f2(valuetype StructUnion01/U& x) cil managed + { + // Code size 23 (0x17) + .maxstack 4 + .locals init (valuetype StructUnion01/U V_0) + IL_0000: ldarg.0 + IL_0001: ldobj StructUnion01/U + IL_0006: stloc.0 + IL_0007: ldloca.s V_0 + IL_0009: ldfld int32 StructUnion01/U::item1 + IL_000e: ldloca.s V_0 + IL_0010: ldfld int32 StructUnion01/U::item2 + IL_0015: add + IL_0016: ret + } // end of method StructUnion01::f2 + + .method public static int32 f3(valuetype StructUnion01/U& x) cil managed + { + // Code size 49 (0x31) + .maxstack 4 + .locals init (valuetype StructUnion01/U V_0) + IL_0000: ldarg.0 + IL_0001: ldobj StructUnion01/U + IL_0006: stloc.0 + IL_0007: ldloca.s V_0 + IL_0009: ldfld int32 StructUnion01/U::item1 + IL_000e: ldc.i4.3 + IL_000f: sub + IL_0010: switch ( + IL_0029) + IL_0019: ldloca.s V_0 + IL_001b: ldfld int32 StructUnion01/U::item1 + IL_0020: ldloca.s V_0 + IL_0022: ldfld int32 StructUnion01/U::item2 + IL_0027: add + IL_0028: ret + + IL_0029: ldloca.s V_0 + IL_002b: ldfld int32 StructUnion01/U::item2 + IL_0030: ret + } // end of method StructUnion01::f3 + + .method public static int32 f4(valuetype StructUnion01/U& x, + valuetype StructUnion01/U& y) cil managed + { + .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationArgumentCountsAttribute::.ctor(int32[]) = ( 01 00 02 00 00 00 01 00 00 00 01 00 00 00 00 00 ) + // Code size 146 (0x92) + .maxstack 6 + .locals init (valuetype StructUnion01/U V_0, + valuetype StructUnion01/U V_1, + int32 V_2, + int32 V_3, + int32 V_4, + int32 V_5) + IL_0000: ldarg.0 + IL_0001: ldobj StructUnion01/U + IL_0006: stloc.0 + IL_0007: ldarg.1 + IL_0008: ldobj StructUnion01/U + IL_000d: stloc.1 + IL_000e: ldloca.s V_0 + IL_0010: ldfld int32 StructUnion01/U::item1 + IL_0015: ldc.i4.3 + IL_0016: sub + IL_0017: switch ( + IL_004c) + IL_0020: ldloca.s V_1 + IL_0022: ldfld int32 StructUnion01/U::item2 + IL_0027: stloc.2 + IL_0028: ldloca.s V_1 + IL_002a: ldfld int32 StructUnion01/U::item1 + IL_002f: stloc.3 + IL_0030: ldloca.s V_0 + IL_0032: ldfld int32 StructUnion01/U::item2 + IL_0037: stloc.s V_4 + IL_0039: ldloca.s V_0 + IL_003b: ldfld int32 StructUnion01/U::item1 + IL_0040: stloc.s V_5 + IL_0042: ldloc.s V_5 + IL_0044: ldloc.s V_4 + IL_0046: add + IL_0047: ldloc.3 + IL_0048: add + IL_0049: ldloc.2 + IL_004a: add + IL_004b: ret + + IL_004c: ldloca.s V_1 + IL_004e: ldfld int32 StructUnion01/U::item1 + IL_0053: ldc.i4.5 + IL_0054: sub + IL_0055: switch ( + IL_0082) + IL_005e: ldloca.s V_1 + IL_0060: ldfld int32 StructUnion01/U::item2 + IL_0065: ldloca.s V_1 + IL_0067: ldfld int32 StructUnion01/U::item1 + IL_006c: ldloca.s V_0 + IL_006e: ldfld int32 StructUnion01/U::item2 + IL_0073: ldloca.s V_0 + IL_0075: ldfld int32 StructUnion01/U::item1 + IL_007a: stloc.s V_5 + IL_007c: stloc.s V_4 + IL_007e: stloc.3 + IL_007f: stloc.2 + IL_0080: br.s IL_0042 + + IL_0082: ldloca.s V_0 + IL_0084: ldfld int32 StructUnion01/U::item2 + IL_0089: ldloca.s V_1 + IL_008b: ldfld int32 StructUnion01/U::item2 + IL_0090: add + IL_0091: ret + } // end of method StructUnion01::f4 + +} // end of class StructUnion01 + +.class private abstract auto ansi sealed ''.$StructUnion01 + extends [mscorlib]System.Object +{ +} // end of class ''.$StructUnion01 + + +// ============================================================= + +// *********** DISASSEMBLY COMPLETE *********************** diff --git a/tests/fsharpqa/Source/Optimizations/Inlining/env.lst b/tests/fsharpqa/Source/Optimizations/Inlining/env.lst index 36d62b41f3d5..29c1d15832e3 100644 --- a/tests/fsharpqa/Source/Optimizations/Inlining/env.lst +++ b/tests/fsharpqa/Source/Optimizations/Inlining/env.lst @@ -1,2 +1,3 @@ NoMT SOURCE=Match01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match01.dll" # Match01.fs NoMT SOURCE=Match02.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match02.dll" # Match02.fs +NoMT SOURCE=StructUnion01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd StructUnion01.dll" # Match02.fs From 583214b7c5a2375cdae0844c7ab9b81e0b0ce767 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 17 Jun 2016 01:32:43 +0100 Subject: [PATCH 11/12] fix new test for struct union codegen --- tests/fsharpqa/Source/Optimizations/Inlining/env.lst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/fsharpqa/Source/Optimizations/Inlining/env.lst b/tests/fsharpqa/Source/Optimizations/Inlining/env.lst index 29c1d15832e3..9c95c7c65455 100644 --- a/tests/fsharpqa/Source/Optimizations/Inlining/env.lst +++ b/tests/fsharpqa/Source/Optimizations/Inlining/env.lst @@ -1,3 +1,3 @@ NoMT SOURCE=Match01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match01.dll" # Match01.fs NoMT SOURCE=Match02.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd Match02.dll" # Match02.fs -NoMT SOURCE=StructUnion01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd StructUnion01.dll" # Match02.fs +NoMT SOURCE=StructUnion01.fs SCFLAGS="-a --optimize+" COMPILE_ONLY=1 POSTCMD="..\\CompareIL.cmd StructUnion01.dll" # StructUnion01.fs From 8b77f6270c75ba144849bf8a79f907389b30b8e2 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 21 Jun 2016 00:40:07 +0100 Subject: [PATCH 12/12] update list matching --- src/fsharp/PatternMatchCompilation.fs | 72 +++++++++++++++------------ 1 file changed, 41 insertions(+), 31 deletions(-) diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 6bff652145d7..10e6a6b1795e 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -462,20 +462,16 @@ let ChooseInvestigationPointLeftToRight frontiers = -#if OPTIMIZE_LIST_MATCHING +#if !OLD_LIST_MATCHING // This is an initial attempt to remove extra typetests/castclass for simple list pattern matching "match x with h::t -> ... | [] -> ..." // The problem with this technique is that it creates extra locals which inhibit the process of converting pattern matches into linear let bindings. let (|ListConsDiscrim|_|) g = function - | (Test.UnionCase (ucref,tinst)) - (* check we can use a simple 'isinst' instruction *) - when tyconRefEq g ucref.TyconRef g.list_tcr_canon & ucref.CaseName = "op_ColonColon" -> Some tinst + | (Test.UnionCase (ucref,tinst)) when g.unionCaseRefEq ucref g.cons_ucref -> Some tinst | _ -> None -let (|ListEmptyDiscrim|_|) g = function - | (Test.UnionCase (ucref,tinst)) - (* check we can use a simple 'isinst' instruction *) - when tyconRefEq g ucref.TyconRef g.list_tcr_canon & ucref.CaseName = "op_Nil" -> Some tinst +let (|ListNilDiscrim|_|) g = function + | (Test.UnionCase (ucref,tinst)) when g.unionCaseRefEq ucref g.nil_ucref -> Some tinst | _ -> None #endif @@ -494,7 +490,6 @@ let (|ListEmptyDiscrim|_|) g = function /// switches, string switches and floating point switches are treated in the /// same way as Test.IsInst. let rec BuildSwitch inpExprOpt g expr edges dflt m = - if verbose then dprintf "--> BuildSwitch@%a, #edges = %A, dflt.IsSome = %A\n" outputRange m (List.length edges) (Option.isSome dflt); match edges,dflt with | [], None -> failwith "internal error: no edges and no default" | [], Some dflt -> dflt (* NOTE: first time around, edges<>[] *) @@ -512,13 +507,14 @@ let rec BuildSwitch inpExprOpt g expr edges dflt m = | (TCase((Test.IsNull | Test.IsInst _),_) as edge):: edges, dflt -> TDSwitch(expr,[edge],Some (BuildSwitch inpExprOpt g expr edges dflt m),m) -#if OPTIMIZE_LIST_MATCHING - // 'cons/nil' tests where we have stored the result of the cons test in an 'isinst' in a variable - // In this case the 'expr' already holds the result of the 'isinst' test. - | [TCase(ListConsDiscrim g tinst, consCase)], Some emptyCase - | [TCase(ListEmptyDiscrim g tinst, emptyCase)], Some consCase - | [TCase(ListEmptyDiscrim g _, emptyCase); TCase(ListConsDiscrim g tinst, consCase)], None - | [TCase(ListConsDiscrim g tinst, consCase); TCase(ListEmptyDiscrim g _, emptyCase)], None +#if !OLD_LIST_MATCHING + // 'cons/nil' tests where we have stored the result of TailOrNull in an inpExprOpt pre-bound variable. + // In this case the 'expr' already holds the result of the 'tail', and the switch can be an IsNull test on that + // value. + | [TCase(ListConsDiscrim g _, consCase)], Some emptyCase + | [TCase(ListNilDiscrim g _, emptyCase)], Some consCase + | [TCase(ListNilDiscrim g _, emptyCase); TCase(ListConsDiscrim g _, consCase)], None + | [TCase(ListConsDiscrim g _, consCase); TCase(ListNilDiscrim g _, emptyCase)], None when isSome inpExprOpt -> TDSwitch(expr, [TCase(Test.IsNull, emptyCase)], Some consCase, m) #endif @@ -792,7 +788,7 @@ let CompilePatternBasic if debug then dprintf "chooseSimultaneousEdgeSet\n"; let simulSetOfEdgeDiscrims,fallthroughPathFrontiers = ChooseSimultaneousEdges frontiers path - let inpExprOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr + let inpExprOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr // For each case, recursively compile the residue decision trees that result if that case successfully matches let simulSetOfCases, _ = CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims inpExprOpt @@ -912,20 +908,23 @@ let CompilePatternBasic -#if OPTIMIZE_LIST_MATCHING - | [EdgeDiscrim(_, ListConsDiscrim g tinst,m); EdgeDiscrim(_, ListEmptyDiscrim g _, _)] - | [EdgeDiscrim(_, ListEmptyDiscrim g _, _); EdgeDiscrim(_, ListConsDiscrim g tinst, m)] +#if !OLD_LIST_MATCHING + // 'cons/nil' tests: we store the result of TailOrNull in an inpExprOpt pre-bound variable. + // The switch can be an IsNull test on that value. + | [EdgeDiscrim(_, ListConsDiscrim g tinst,m); EdgeDiscrim(_, ListNilDiscrim g _, _)] + | [EdgeDiscrim(_, ListNilDiscrim g _, _); EdgeDiscrim(_, ListConsDiscrim g tinst, m)] | [EdgeDiscrim(_, ListConsDiscrim g tinst, m)] - | [EdgeDiscrim(_, ListEmptyDiscrim g tinst, m)] - (* check we can use a simple 'isinst' instruction *) + | [EdgeDiscrim(_, ListNilDiscrim g tinst, m)] when isNil topgtvs -> - let ucaseTy = (mkProvenUnionCaseTy g.cons_ucref tinst) - let v,vexp = mkCompGenLocal m "unionTestResult" ucaseTy + let listTy = mkListTy g (List.head tinst) + let v,vexp = mkCompGenLocal m "tailOrNullResult" listTy if topv.IsMemberOrModuleBinding then AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + // Get the input let argexp = GetSubExprOfInput subexpr - let appexp = mkIsInst ucaseTy argexp matchm + // Get the TailOrNull field + let appexp = mkUnionCaseFieldGetUnprovenViaExprAddr(argexp,g.cons_ucref,tinst,1,matchm) Some vexp,Some (mkInvisibleBind v appexp) #endif @@ -967,7 +966,7 @@ let CompilePatternBasic let resPostBindOpt,ucaseBindOpt = match discrim with | Test.UnionCase (ucref, tinst) when -#if OPTIMIZE_LIST_MATCHING +#if !OLD_LIST_MATCHING isNone inpExprOpt && #endif (isNil topgtvs && @@ -1102,11 +1101,22 @@ let CompilePatternBasic match resPostBindOpt with | Some e -> mkUnionCaseFieldGetProvenViaExprAddr (e,ucref1,tinst,j,exprm) | None -> - let exprIn = - match inpExprOpt with - | Some addrexp -> addrexp - | None -> accessf tpinst exprIn - mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn,ucref1,instTypes tpinst tyargs,j,exprm) +#if !OLD_LIST_MATCHING + if g.unionCaseRefEq ucref1 g.cons_ucref then + if j = 0 then + let exprIn = accessf tpinst exprIn + mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn,ucref1,instTypes tpinst tyargs,j,exprm) + else + assert (j = 1) + assert inpExprOpt.IsSome + inpExprOpt.Value // use the saved value of TailOrNull for the tail projection + else +#endif + let exprIn = + match inpExprOpt with + | Some addrexp -> addrexp + | None -> accessf tpinst exprIn + mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn,ucref1,instTypes tpinst tyargs,j,exprm) mkSubFrontiers path accessf' active' argpats (fun path j -> PathUnionConstr(path,ucref1,tyargs,j)) | Test.UnionCase _ ->