Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

fix anon recd creation bug (#6434) #6619

Merged
merged 3 commits into from
Apr 24, 2019
Merged

fix anon recd creation bug (#6434) #6619

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
4c4b29c
fix anon recd creation bug
dsyme Apr 23, 2019
23cdd2a
fix generation, make it more efficient
dsyme Apr 23, 2019
d17939d
fix feasible equality for anonymous records
dsyme Apr 23, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
139 changes: 72 additions & 67 deletions src/fsharp/IlxGen.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1356,57 +1356,65 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu

let generateAnonType genToStringMethod (isStruct, ilTypeRef, nms) =

let flds = [ for (i, nm) in Array.indexed nms -> (nm, nm + "@", ILType.TypeVar (uint16 i)) ]
let propTys = [ for (i, nm) in Array.indexed nms -> nm, ILType.TypeVar (uint16 i) ]

// Note that this alternative below would give the same names as C#, but the generated
// comparison/equality doesn't know about these names.
//let flds = [ for (i, nm) in Array.indexed nms -> (nm, "<" + nm + ">" + "i__Field", ILType.TypeVar (uint16 i)) ]
let ilCtorRef = mkILMethRef(ilTypeRef, ILCallingConv.Instance, ".ctor", 0, List.map snd propTys, ILType.Void)

let ilGenericParams =
[ for nm in nms ->
{ Name = sprintf "<%s>j__TPar" nm
Constraints = []
Variance=NonVariant
CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs
HasReferenceTypeConstraint=false
HasNotNullableValueTypeConstraint=false
HasDefaultConstructorConstraint= false
MetadataIndex = NoMetadataIdx } ]
let ilMethodRefs =
[| for (propName, propTy) in propTys ->
mkILMethRef (ilTypeRef, ILCallingConv.Instance, "get_" + propName, 0, [], propTy) |]

let ilTy = mkILFormalNamedTy (if isStruct then ILBoxity.AsValue else ILBoxity.AsObject) ilTypeRef ilGenericParams
let ilTy = mkILNamedTy (if isStruct then ILBoxity.AsValue else ILBoxity.AsObject) ilTypeRef (List.map snd propTys)

// Generate the IL fields
let ilFieldDefs =
mkILFields
[ for (_, fldName, fldTy) in flds ->
let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Private)
fdef.With(customAttrs = mkILCustomAttrs [ g.DebuggerBrowsableNeverAttribute ]) ]
if ilTypeRef.Scope.IsLocalRef then

let flds = [ for (i, nm) in Array.indexed nms -> (nm, nm + "@", ILType.TypeVar (uint16 i)) ]

let ilGenericParams =
[ for nm in nms ->
{ Name = sprintf "<%s>j__TPar" nm
Constraints = []
Variance=NonVariant
CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs
HasReferenceTypeConstraint=false
HasNotNullableValueTypeConstraint=false
HasDefaultConstructorConstraint= false
MetadataIndex = NoMetadataIdx } ]

let ilTy = mkILFormalNamedTy (if isStruct then ILBoxity.AsValue else ILBoxity.AsObject) ilTypeRef ilGenericParams

// Generate the IL fields
let ilFieldDefs =
mkILFields
[ for (_, fldName, fldTy) in flds ->
let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Private)
fdef.With(customAttrs = mkILCustomAttrs [ g.DebuggerBrowsableNeverAttribute ]) ]

// Generate property definitions for the fields compiled as properties
let ilProperties =
mkILProperties
[ for (i, (propName, _fldName, fldTy)) in List.indexed flds ->
ILPropertyDef(name=propName,
attributes=PropertyAttributes.None,
setMethod=None,
getMethod=Some(mkILMethRef(ilTypeRef, ILCallingConv.Instance, "get_" + propName, 0, [], fldTy )),
callingConv=ILCallingConv.Instance.ThisConv,
propertyType=fldTy,
init= None,
args=[],
customAttrs=mkILCustomAttrs [ mkCompilationMappingAttrWithSeqNum g (int SourceConstructFlags.Field) i ]) ]
// Generate property definitions for the fields compiled as properties
let ilProperties =
mkILProperties
[ for (i, (propName, _fldName, fldTy)) in List.indexed flds ->
ILPropertyDef(name=propName,
attributes=PropertyAttributes.None,
setMethod=None,
getMethod=Some(mkILMethRef(ilTypeRef, ILCallingConv.Instance, "get_" + propName, 0, [], fldTy )),
callingConv=ILCallingConv.Instance.ThisConv,
propertyType=fldTy,
init= None,
args=[],
customAttrs=mkILCustomAttrs [ mkCompilationMappingAttrWithSeqNum g (int SourceConstructFlags.Field) i ]) ]

let ilMethods =
[ for (propName, fldName, fldTy) in flds ->
mkLdfldMethodDef ("get_" + propName, ILMemberAccess.Public, false, ilTy, fldName, fldTy)
yield! genToStringMethod ilTy ]
let ilMethods =
[ for (propName, fldName, fldTy) in flds ->
mkLdfldMethodDef ("get_" + propName, ILMemberAccess.Public, false, ilTy, fldName, fldTy)
yield! genToStringMethod ilTy ]

let ilBaseTy = (if isStruct then g.iltyp_ValueType else g.ilg.typ_Object)
let ilBaseTy = (if isStruct then g.iltyp_ValueType else g.ilg.typ_Object)

let ilCtorDef = mkILSimpleStorageCtorWithParamNames(None, (if isStruct then None else Some ilBaseTy.TypeSpec), ilTy, [], flds, ILMemberAccess.Public)
let ilCtorRef = mkRefToILMethod(ilTypeRef, ilCtorDef)
let ilMethodRefs = [| for mdef in ilMethods -> mkRefToILMethod(ilTypeRef, mdef) |]

if ilTypeRef.Scope.IsLocalRef then
let ilCtorDef = mkILSimpleStorageCtorWithParamNames(None, (if isStruct then None else Some ilBaseTy.TypeSpec), ilTy, [], flds, ILMemberAccess.Public)

// Create a tycon that looks exactly like a record definition, to help drive the generation of equality/comparison code
let m = range0
Expand Down Expand Up @@ -1482,12 +1490,12 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu
/// static init fields on script modules.
let mutable scriptInitFspecs: (ILFieldSpec * range) list = []

member mgbuf.AddScriptInitFieldSpec(fieldSpec, range) =
member __.AddScriptInitFieldSpec (fieldSpec, range) =
scriptInitFspecs <- (fieldSpec, range) :: scriptInitFspecs

/// This initializes the script in #load and fsc command-line order causing their
/// sideeffects to be executed.
member mgbuf.AddInitializeScriptsInOrderToEntryPoint() =
member mgbuf.AddInitializeScriptsInOrderToEntryPoint () =
// Get the entry point and initialized any scripts in order.
match explicitEntryPointInfo with
| Some tref ->
Expand All @@ -1496,57 +1504,54 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu
scriptInitFspecs |> List.iter IntializeCompiledScript
| None -> ()

member mgbuf.GenerateRawDataValueType(cloc, size) =
member __.GenerateRawDataValueType (cloc, size) =
// Byte array literals require a ValueType of size the required number of bytes.
// With fsi.exe, S.R.Emit TypeBuilder CreateType has restrictions when a ValueType VT is nested inside a type T, and T has a field of type VT.
// To avoid this situation, these ValueTypes are generated under the private implementation rather than in the current cloc. [was bug 1532].
let cloc = CompLocForPrivateImplementationDetails cloc
rawDataValueTypeGenerator.Apply((cloc, size))

member mgbuf.GenerateAnonType(genToStringMethod, anonInfo: AnonRecdTypeInfo) =
member __.GenerateAnonType (genToStringMethod, anonInfo: AnonRecdTypeInfo) =
let isStruct = evalAnonInfoIsStruct anonInfo
let key = anonInfo.Stamp
match anonTypeTable.Table.TryGetValue key with
| true, res -> res
| _ ->
if not (anonTypeTable.Table.ContainsKey key) then
let info = generateAnonType genToStringMethod (isStruct, anonInfo.ILTypeRef, anonInfo.SortedNames)
anonTypeTable.Table.[key] <- info
info

member mgbuf.LookupAnonType(anonInfo: AnonRecdTypeInfo) =
member __.LookupAnonType (anonInfo: AnonRecdTypeInfo) =
match anonTypeTable.Table.TryGetValue anonInfo.Stamp with
| true, res -> res
| _ -> failwithf "the anonymous record %A has not been generated in the pre-phase of generating this module" anonInfo.ILTypeRef

member mgbuf.GrabExtraBindingsToGenerate() =
member __.GrabExtraBindingsToGenerate () =
let result = extraBindingsToGenerate
extraBindingsToGenerate <- []
result

member mgbuf.AddTypeDef(tref: ILTypeRef, tdef, eliminateIfEmpty, addAtEnd, tdefDiscards) =
member __.AddTypeDef (tref: ILTypeRef, tdef, eliminateIfEmpty, addAtEnd, tdefDiscards) =
gtdefs.FindNestedTypeDefsBuilder(tref.Enclosing).AddTypeDef(tdef, eliminateIfEmpty, addAtEnd, tdefDiscards)

member mgbuf.GetCurrentFields(tref: ILTypeRef) =
member __.GetCurrentFields (tref: ILTypeRef) =
gtdefs.FindNestedTypeDefBuilder(tref).GetCurrentFields()

member mgbuf.AddReflectedDefinition(vspec: Tast.Val, expr) =
member __.AddReflectedDefinition (vspec: Tast.Val, expr) =
// preserve order by storing index of item
let n = reflectedDefinitions.Count
reflectedDefinitions.Add(vspec, (vspec.CompiledName, n, expr))

member mgbuf.ReplaceNameOfReflectedDefinition(vspec, newName) =
member __.ReplaceNameOfReflectedDefinition (vspec, newName) =
match reflectedDefinitions.TryGetValue vspec with
| true, (name, n, expr) when name <> newName -> reflectedDefinitions.[vspec] <- (newName, n, expr)
| _ -> ()

member mgbuf.AddMethodDef(tref: ILTypeRef, ilMethodDef) =
member __.AddMethodDef (tref: ILTypeRef, ilMethodDef) =
gtdefs.FindNestedTypeDefBuilder(tref).AddMethodDef(ilMethodDef)
if ilMethodDef.IsEntryPoint then
explicitEntryPointInfo <- Some tref

member mgbuf.AddExplicitInitToSpecificMethodDef(cond, tref, fspec, sourceOpt, feefee, seqpt) =
// Authoring a .cctor with effects forces the cctor for the 'initialization' module by doing a dummy store & load of a field
// Doing both a store and load keeps FxCop happier because it thinks the field is useful
member __.AddExplicitInitToSpecificMethodDef (cond, tref, fspec, sourceOpt, feefee, seqpt) =
// Authoring a .cctor with effects forces the cctor for the 'initialization' module by doing a dummy store & load of a field
// Doing both a store and load keeps FxCop happier because it thinks the field is useful
let instrs =
[ yield! (if condition "NO_ADD_FEEFEE_TO_CCTORS" then [] elif condition "ADD_SEQPT_TO_CCTORS" then seqpt else feefee) // mark start of hidden code
yield mkLdcInt32 0
Expand All @@ -1555,25 +1560,26 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu
yield AI_pop]
gtdefs.FindNestedTypeDefBuilder(tref).PrependInstructionsToSpecificMethodDef(cond, instrs, sourceOpt)

member mgbuf.AddEventDef(tref, edef) =
member __.AddEventDef (tref, edef) =
gtdefs.FindNestedTypeDefBuilder(tref).AddEventDef(edef)

member mgbuf.AddFieldDef(tref, ilFieldDef) =
member __.AddFieldDef (tref, ilFieldDef) =
gtdefs.FindNestedTypeDefBuilder(tref).AddFieldDef(ilFieldDef)

member mgbuf.AddOrMergePropertyDef(tref, pdef, m) =
member __.AddOrMergePropertyDef (tref, pdef, m) =
gtdefs.FindNestedTypeDefBuilder(tref).AddOrMergePropertyDef(pdef, m)

member mgbuf.Close() =
member __.Close() =
// old implementation adds new element to the head of list so result was accumulated in reversed order
let orderedReflectedDefinitions =
[for (KeyValue(vspec, (name, n, expr))) in reflectedDefinitions -> n, ((name, vspec), expr)]
|> List.sortBy (fst >> (~-)) // invert the result to get 'order-by-descending' behavior (items in list are 0..* so we don't need to worry about int.MinValue)
|> List.map snd
gtdefs.Close(), orderedReflectedDefinitions
member mgbuf.cenv = cenv
member mgbuf.GetExplicitEntryPointInfo() = explicitEntryPointInfo

member __.cenv = cenv

member __.GetExplicitEntryPointInfo() = explicitEntryPointInfo

/// Record the types of the things on the evaluation stack.
/// Used for the few times we have to flush the IL evaluation stack and to compute maxStack.
Expand Down Expand Up @@ -6408,7 +6414,7 @@ and GenTopImpl cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (TImplFile (qname,

// Generate all the anonymous record types mentioned anywhere in this module
for anonInfo in anonRecdTypes.Values do
mgbuf.GenerateAnonType((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo) |> ignore
mgbuf.GenerateAnonType((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo)

let eenv = {eenv with cloc = { eenv.cloc with TopImplQualifiedName = qname.Text } }

Expand Down Expand Up @@ -7615,7 +7621,6 @@ let ClearGeneratedValue (ctxt: ExecutionContext) (_g: TcGlobals) eenv (v: Val) =
#endif
()


/// The published API from the ILX code generator
type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: ConstraintSolver.TcValF, ccu: Tast.CcuThunk) =

Expand Down
20 changes: 15 additions & 5 deletions src/fsharp/PostInferenceChecks.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -285,6 +285,10 @@ let BindVal cenv env (v: Val) =

let BindVals cenv env vs = List.iter (BindVal cenv env) vs

let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) =
if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then
cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo)

//--------------------------------------------------------------------------
// approx walk of type
//--------------------------------------------------------------------------
Expand Down Expand Up @@ -334,8 +338,7 @@ let rec CheckTypeDeep (cenv: cenv) ((visitTy, visitTyconRefOpt, visitAppTyOpt, v
| Some visitAppTy -> visitAppTy (tcref, tinst)
| None -> ()
| TType_anon (anonInfo, tys) ->
if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then
cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo)
RecordAnonRecdInfo cenv anonInfo
CheckTypesDeep cenv f g env tys

| TType_ucase (_, tinst) -> CheckTypesDeep cenv f g env tinst
Expand Down Expand Up @@ -1011,8 +1014,8 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi
CheckValRef cenv env baseVal m PermitByRefExpr.No
CheckExprsPermitByRefLike cenv env rest

| Expr.Op (c, tyargs, args, m) ->
CheckExprOp cenv env (c, tyargs, args, m) context expr
| Expr.Op (op, tyargs, args, m) ->
CheckExprOp cenv env (op, tyargs, args, m) context expr

// Allow 'typeof<System.Void>' calls as a special case, the only accepted use of System.Void!
| TypeOfExpr g ty when isVoidTy g ty ->
Expand Down Expand Up @@ -1115,7 +1118,14 @@ and CheckExprOp cenv env (op, tyargs, args, m) context expr =
let ctorLimitedZoneCheck() =
if env.ctorLimitedZone then errorR(Error(FSComp.SR.chkObjCtorsCantUseExceptionHandling(), m))

(* Special cases *)
// Ensure anonynous record type requirements are recorded
match op with
| TOp.AnonRecdGet (anonInfo, _)
| TOp.AnonRecd anonInfo ->
RecordAnonRecdInfo cenv anonInfo
| _ -> ()

// Special cases
match op, tyargs, args with
// Handle these as special cases since mutables are allowed inside their bodies
| TOp.While _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)] ->
Expand Down
24 changes: 17 additions & 7 deletions src/fsharp/TypeRelations.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -66,18 +66,28 @@ let rec TypesFeasiblyEquiv ndeep g amap m ty1 ty2 =
let ty1 = stripTyEqns g ty1
let ty2 = stripTyEqns g ty2
match ty1, ty2 with
// QUERY: should these be false for non-equal rigid typars? warn-if-not-rigid typars?
| TType_var _, _
| _, TType_var _ -> true

| TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 ->
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) ->
(evalTupInfoIsStruct anonInfo1.TupInfo = evalTupInfoIsStruct anonInfo2.TupInfo) &&
(match anonInfo1.Assembly, anonInfo2.Assembly with ccu1, ccu2 -> ccuEq ccu1 ccu2) &&
(anonInfo1.SortedNames = anonInfo2.SortedNames) &&
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) ->
evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_fun (d1, r1), TType_fun (d2, r2) ->
(TypesFeasiblyEquiv ndeep g amap m) d1 d2 && (TypesFeasiblyEquiv ndeep g amap m) r1 r2

| TType_measure _, TType_measure _ ->
true

| _ ->
false

Expand All @@ -88,18 +98,18 @@ let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =
let ty1 = stripTyEqns g ty1
let ty2 = stripTyEqns g ty2
match ty1, ty2 with
// QUERY: should these be false for non-equal rigid typars? warn-if-not-rigid typars?
| TType_var _, _ | _, TType_var _ -> true

| TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 ->
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
| TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) ->
evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
| TType_fun (d1, r1), TType_fun (d2, r2) ->
(TypesFeasiblyEquiv ndeep g amap m) d1 d2 && (TypesFeasiblyEquiv ndeep g amap m) r1 r2

| TType_tuple _, TType_tuple _
| TType_anon _, TType_anon _
| TType_fun _, TType_fun _ -> TypesFeasiblyEquiv ndeep g amap m ty1 ty2

| TType_measure _, TType_measure _ ->
true

| _ ->
// F# reference types are subtypes of type 'obj'
(isObjTy g ty1 && (canCoerce = CanCoerce || isRefTy g ty2))
Expand Down
12 changes: 12 additions & 0 deletions tests/fsharp/core/anon/test.fsx
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -67,6 +67,18 @@ module CrossAssemblyTestTupleStruct =
check "svrknvio4" (let res = SampleAPITupleStruct.SampleFunctionReturningStructTuple() in match res with (x,y) -> x + y.Length) 4
tests()

module TypeNotGeneratedBug =

let foo (_: obj) = ()

let bar() = foo {| ThisIsUniqueToThisTest6353 = 1 |}

module FeasibleEqualityNotImplemented =
type R = {| number: int |}
let e = Event< R>()
e.Trigger {|number = 3|}
e.Publish.Add (printfn "%A") // error

#if TESTS_AS_APP
let RUN() = !failures
#else
Expand Down