From ba3fee7652c02512872e6e80f4d7c6b6767b15f8 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Jun 2016 20:28:25 +0100 Subject: [PATCH] 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 6224d843be1..002dbd63f6b 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 8287cfb3aa1..5a0cdee0b60 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 4a81afa084f..147f5baf987 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 819cfdb74ee..b8289f30b0f 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 ac8b23f5b14..282ab07d95a 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 efc5056aac6..d183fe0796b 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 db96d9cdb4c..b7413fbf698 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 3b4031007c1..842561c857b 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 fbab553659d..3800e29755b 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 28b15426e03..c52663bd402 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 42f038b67bc..52ea6fbf388 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 e7f357eb825..55ee5241a28 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 9ebd2bafafe..52345ff8c43 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 0bb9b2dfe87..e3451d188f1 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 0dae5cdfbf2..22400641b79 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 275ffbe2137..9519c65f50d 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 22090236d4b..3361b5ec54f 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 d82e0671bf7..fd4e2c2f6be 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 912c72872db..651c927bc04 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 2b68fbb7c57..cf37fbfc193 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 5df8b030df1..f9957bc53cf 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 93d8287315d..76e45b9b815 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 962181713ab..c3154c8eb7b 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 fac033126f9..c4cdfab0625 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 09d5e41e29d..47311b27700 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 63c66b9823f..77c5eb51c38 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 3a58778211b..6422fa14045 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