Skip to content

Commit

Permalink
cleanup and pre-prep for #6810 (#8503)
Browse files Browse the repository at this point in the history
  • Loading branch information
@dsyme
dsyme authored Feb 7, 2020
1 parent c648e2a commit b814ad9
Show file tree
Hide file tree
Showing 8 changed files with 219 additions and 192 deletions.
128 changes: 10 additions & 118 deletions src/fsharp/ConstraintSolver.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3024,130 +3024,22 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) =
|> RaiseOperationResult
| _ -> ())

let CreateCodegenState tcVal g amap =
{ g = g
amap = amap
TcVal = tcVal
ExtraCxs = HashMultiMap(10, HashIdentity.Structural)
InfoReader = new InfoReader(g, amap) }

let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo: TraitConstraintInfo) argExprs = trackErrors {
let css =
{ g = g
amap = amap
TcVal = tcVal
ExtraCxs = HashMultiMap(10, HashIdentity.Structural)
InfoReader = new InfoReader(g, amap) }
let css = CreateCodegenState tcVal g amap

let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g)

let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m NoTrace traitInfo

let sln =
match traitInfo.Solution with
| None -> Choice5Of5()
| Some sln ->

// Given the solution information, reconstruct the MethInfo for the solution
match sln with
| ILMethSln(origTy, extOpt, mref, minst) ->
let metadataTy = convertToTypeWithMetadataIfPossible g origTy
let tcref = tcrefOfAppTy g metadataTy
let mdef = IL.resolveILMethodRef tcref.ILTyconRawMetadata mref
let ilMethInfo =
match extOpt with
| None -> MethInfo.CreateILMeth(amap, m, origTy, mdef)
| Some ilActualTypeRef ->
let actualTyconRef = Import.ImportILTypeRef amap m ilActualTypeRef
MethInfo.CreateILExtensionMeth(amap, m, origTy, actualTyconRef, None, mdef)
Choice1Of5 (ilMethInfo, minst)

| FSMethSln(ty, vref, minst) ->
Choice1Of5 (FSMeth(g, ty, vref, None), minst)

| FSRecdFieldSln(tinst, rfref, isSetProp) ->
Choice2Of5 (tinst, rfref, isSetProp)

| FSAnonRecdFieldSln(anonInfo, tinst, i) ->
Choice3Of5 (anonInfo, tinst, i)

| BuiltInSln ->
Choice5Of5 ()

| ClosedExprSln expr ->
Choice4Of5 expr
return!
match sln with
| Choice1Of5(minfo, methArgTys) ->
let argExprs =
// FIX for #421894 - typechecker assumes that coercion can be applied for the trait calls arguments but codegen doesn't emit coercion operations
// result - generation of non-verifiable code
// fix - apply coercion for the arguments (excluding 'receiver' argument in instance calls)

// flatten list of argument types (looks like trait calls with curried arguments are not supported so we can just convert argument list in straightforward way)
let argTypes =
minfo.GetParamTypes(amap, m, methArgTys)
|> List.concat
// do not apply coercion to the 'receiver' argument
let receiverArgOpt, argExprs =
if minfo.IsInstance then
match argExprs with
| h :: t -> Some h, t
| argExprs -> None, argExprs
else None, argExprs
let convertedArgs = (argExprs, argTypes) ||> List.map2 (fun expr expectedTy -> mkCoerceIfNeeded g expectedTy (tyOfExpr g expr) expr)
match receiverArgOpt with
| Some r -> r :: convertedArgs
| None -> convertedArgs

// Fix bug 1281: If we resolve to an instance method on a struct and we haven't yet taken
// the address of the object then go do that
if minfo.IsStruct && minfo.IsInstance && (match argExprs with [] -> false | h :: _ -> not (isByrefTy g (tyOfExpr g h))) then
let h, t = List.headAndTail argExprs
let wrap, h', _readonly, _writeonly = mkExprAddrOfExpr g true false PossiblyMutates h None m
ResultD (Some (wrap (Expr.Op (TOp.TraitCall (traitInfo), [], (h' :: t), m))))
else
ResultD (Some (MakeMethInfoCall amap m minfo methArgTys argExprs ))

| Choice2Of5 (tinst, rfref, isSet) ->
let res =
match isSet, rfref.RecdField.IsStatic, argExprs.Length with

// static setter
| true, true, 1 ->
Some (mkStaticRecdFieldSet (rfref, tinst, argExprs.[0], m))

// instance setter
| true, false, 2 ->
// 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', _readonly, _writeonly = 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))

// static getter
| false, true, 0 ->
Some (mkStaticRecdFieldGet (rfref, tinst, m))

// instance getter
| false, false, 1 ->
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

| Choice3Of5 (anonInfo, tinst, i) ->
let res =
let tupInfo = anonInfo.TupInfo
if evalTupInfoIsStruct tupInfo && isByrefTy g (tyOfExpr g argExprs.[0]) then
Some (mkAnonRecdFieldGetViaExprAddr (anonInfo, argExprs.[0], tinst, i, m))
else
Some (mkAnonRecdFieldGet g (anonInfo, argExprs.[0], tinst, i, m))
ResultD res

| Choice4Of5 expr ->
ResultD (Some (MakeApplicationAndBetaReduce g (expr, tyOfExpr g expr, [], argExprs, m)))

| Choice5Of5 () ->
ResultD None
let sln = GenWitnessExpr amap g m traitInfo argExprs
return sln
}

let ChooseTyparSolutionAndSolve css denv tp =
Expand Down
15 changes: 4 additions & 11 deletions src/fsharp/IlxGen.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3789,9 +3789,9 @@ and GenQuotation cenv cgbuf eenv (ast, conv, m, ety) sequel =
| None ->
try
let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, QuotationTranslator.IsReflectedDefinition.No)
let astSpec = QuotationTranslator.ConvExprPublic qscope QuotationTranslator.QuotationTranslationEnv.Empty ast
let referencedTypeDefs, spliceTypes, spliceArgExprs = qscope.Close()
referencedTypeDefs, List.map fst spliceTypes, List.map fst spliceArgExprs, astSpec
let astSpec = QuotationTranslator.ConvExprPublic qscope ast
let referencedTypeDefs, typeSplices, exprSplices = qscope.Close()
referencedTypeDefs, List.map fst typeSplices, List.map fst exprSplices, astSpec
with
QuotationTranslator.InvalidQuotedTerm e -> error e

Expand Down Expand Up @@ -7579,14 +7579,7 @@ let GenerateCode (cenv, anonTypeTable, eenv, TypedAssemblyAfterOptimization file
let defns =
reflectedDefinitions |> List.choose (fun ((methName, v), e) ->
try
let ety = tyOfExpr g e
let tps, taue, _ =
match e with
| Expr.TyLambda (_, tps, b, _, _) -> tps, b, applyForallTy g ety (List.map mkTyparTy tps)
| _ -> [], e, ety
let env = QuotationTranslator.QuotationTranslationEnv.Empty.BindTypars tps
let astExpr = QuotationTranslator.ConvExprPublic qscope env taue
let mbaseR = QuotationTranslator.ConvMethodBase qscope env (methName, v)
let mbaseR, astExpr = QuotationTranslator.ConvReflectedDefinition qscope methName v e

Some(mbaseR, astExpr)
with
Expand Down
123 changes: 123 additions & 0 deletions src/fsharp/MethodCalls.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1782,3 +1782,126 @@ let CheckRecdFieldMutation m denv (rfinfo: RecdFieldInfo) =
if not rfinfo.RecdField.IsMutable then
errorR (FieldNotMutable (denv, rfinfo.RecdFieldRef, m))


/// Generate a witness for the given (solved) constraint. Five possiblilities are taken
/// into account.
/// 1. The constraint is solved by a .NET-declared method or an F#-declared method
/// 2. The constraint is solved by an F# record field
/// 3. The constraint is solved by an F# anonymous record field
/// 4. The constraint is considered solved by a "built in" solution
/// 5. The constraint is solved by a closed expression given by a provided method from a type provider
///
/// In each case an expression is returned where the method is applied to the given arguments, or the
/// field is dereferenced.
///
/// None is returned in the cases where the trait has not been solved (e.g. is part of generic code)
/// or there is an unexpected mismatch of some kind.
let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =

let sln =
match traitInfo.Solution with
| None -> Choice5Of5()
| Some sln ->

// Given the solution information, reconstruct the MethInfo for the solution
match sln with
| ILMethSln(origTy, extOpt, mref, minst) ->
let metadataTy = convertToTypeWithMetadataIfPossible g origTy
let tcref = tcrefOfAppTy g metadataTy
let mdef = resolveILMethodRef tcref.ILTyconRawMetadata mref
let ilMethInfo =
match extOpt with
| None -> MethInfo.CreateILMeth(amap, m, origTy, mdef)
| Some ilActualTypeRef ->
let actualTyconRef = Import.ImportILTypeRef amap m ilActualTypeRef
MethInfo.CreateILExtensionMeth(amap, m, origTy, actualTyconRef, None, mdef)
Choice1Of5 (ilMethInfo, minst)

| FSMethSln(ty, vref, minst) ->
Choice1Of5 (FSMeth(g, ty, vref, None), minst)

| FSRecdFieldSln(tinst, rfref, isSetProp) ->
Choice2Of5 (tinst, rfref, isSetProp)

| FSAnonRecdFieldSln(anonInfo, tinst, i) ->
Choice3Of5 (anonInfo, tinst, i)

| BuiltInSln ->
Choice5Of5 ()

| ClosedExprSln expr ->
Choice4Of5 expr
match sln with
| Choice1Of5(minfo, methArgTys) ->
let argExprs =
// FIX for #421894 - typechecker assumes that coercion can be applied for the trait calls arguments but codegen doesn't emit coercion operations
// result - generation of non-verifiable code
// fix - apply coercion for the arguments (excluding 'receiver' argument in instance calls)

// flatten list of argument types (looks like trait calls with curried arguments are not supported so we can just convert argument list in straightforward way)
let argTypes =
minfo.GetParamTypes(amap, m, methArgTys)
|> List.concat
// do not apply coercion to the 'receiver' argument
let receiverArgOpt, argExprs =
if minfo.IsInstance then
match argExprs with
| h :: t -> Some h, t
| argExprs -> None, argExprs
else None, argExprs
let convertedArgs = (argExprs, argTypes) ||> List.map2 (fun expr expectedTy -> mkCoerceIfNeeded g expectedTy (tyOfExpr g expr) expr)
match receiverArgOpt with
| Some r -> r :: convertedArgs
| None -> convertedArgs

// Fix bug 1281: If we resolve to an instance method on a struct and we haven't yet taken
// the address of the object then go do that
if minfo.IsStruct && minfo.IsInstance && (match argExprs with [] -> false | h :: _ -> not (isByrefTy g (tyOfExpr g h))) then
let h, t = List.headAndTail argExprs
let wrap, h', _readonly, _writeonly = mkExprAddrOfExpr g true false PossiblyMutates h None m
Some (wrap (Expr.Op (TOp.TraitCall (traitInfo), [], (h' :: t), m)))
else
Some (MakeMethInfoCall amap m minfo methArgTys argExprs )

| Choice2Of5 (tinst, rfref, isSet) ->
match isSet, rfref.RecdField.IsStatic, argExprs.Length with

// static setter
| true, true, 1 ->
Some (mkStaticRecdFieldSet (rfref, tinst, argExprs.[0], m))

// instance setter
| true, false, 2 ->
// 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', _readonly, _writeonly = 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))

// static getter
| false, true, 0 ->
Some (mkStaticRecdFieldGet (rfref, tinst, m))

// instance getter
| false, false, 1 ->
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

| Choice3Of5 (anonInfo, tinst, i) ->
let tupInfo = anonInfo.TupInfo
if evalTupInfoIsStruct tupInfo && isByrefTy g (tyOfExpr g argExprs.[0]) then
Some (mkAnonRecdFieldGetViaExprAddr (anonInfo, argExprs.[0], tinst, i, m))
else
Some (mkAnonRecdFieldGet g (anonInfo, argExprs.[0], tinst, i, m))

| Choice4Of5 expr ->
Some (MakeApplicationAndBetaReduce g (expr, tyOfExpr g expr, [], argExprs, m))

| Choice5Of5 () ->
None
17 changes: 6 additions & 11 deletions src/fsharp/PostInferenceChecks.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -973,7 +973,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi
// Translate to quotation data
try
let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, QuotationTranslator.IsReflectedDefinition.No)
let qdata = QuotationTranslator.ConvExprPublic qscope QuotationTranslator.QuotationTranslationEnv.Empty ast
let qdata = QuotationTranslator.ConvExprPublic qscope ast
let typeDefs, spliceTypes, spliceExprs = qscope.Close()
match savedConv.Value with
| None -> savedConv:= Some (typeDefs, List.map fst spliceTypes, List.map fst spliceExprs, qdata)
Expand Down Expand Up @@ -1752,18 +1752,13 @@ and CheckBinding cenv env alwaysCheckNoReraise context (TBind(v, bindRhs, _) as
// no real need for that except that it helps us to bundle all reflected definitions up into
// one blob for pickling to the binary format
try
let ety = tyOfExpr g bindRhs
let tps, taue, _ =
match bindRhs with
| Expr.TyLambda (_, tps, b, _, _) -> tps, b, applyForallTy g ety (List.map mkTyparTy tps)
| _ -> [], bindRhs, ety
let env = QuotationTranslator.QuotationTranslationEnv.Empty.BindTypars tps
let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, QuotationTranslator.IsReflectedDefinition.Yes)
QuotationTranslator.ConvExprPublic qscope env taue |> ignore
let _, _, argExprs = qscope.Close()
if not (isNil argExprs) then
let methName = v.CompiledName g.CompilerGlobalState
QuotationTranslator.ConvReflectedDefinition qscope methName v bindRhs |> ignore

let _, _, exprSplices = qscope.Close()
if not (isNil exprSplices) then
errorR(Error(FSComp.SR.chkReflectedDefCantSplice(), v.Range))
QuotationTranslator.ConvMethodBase qscope env (v.CompiledName g.CompilerGlobalState, v) |> ignore
with
| QuotationTranslator.InvalidQuotedTerm e ->
errorR e
Expand Down
22 changes: 12 additions & 10 deletions src/fsharp/QuotationPickler.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,8 +45,6 @@ type VarData =
vType: TypeData
vMutable: bool }

type FieldData = NamedTypeData * string
type RecdFieldData = NamedTypeData * string
type PropInfoData = NamedTypeData * string * TypeData * TypeData list

type CombOp =
Expand Down Expand Up @@ -145,15 +143,15 @@ let mkLetRec (ves, body) =

let mkRecdMk (n, tys, args) = CombExpr(RecdMkOp n, tys, args)

let mkRecdGet ((d1, d2), tyargs, args) = CombExpr(RecdGetOp(d1, d2), tyargs, args)
let mkRecdGet (d1, d2, tyargs, args) = CombExpr(RecdGetOp(d1, d2), tyargs, args)

let mkRecdSet ((d1, d2), tyargs, args) = CombExpr(RecdSetOp(d1, d2), tyargs, args)
let mkRecdSet (d1, d2, tyargs, args) = CombExpr(RecdSetOp(d1, d2), tyargs, args)

let mkUnion ((d1, d2), tyargs, args) = CombExpr(SumMkOp(d1, d2), tyargs, args)
let mkUnion (d1, d2, tyargs, args) = CombExpr(SumMkOp(d1, d2), tyargs, args)

let mkUnionFieldGet ((d1, d2, d3), tyargs, arg) = CombExpr(SumFieldGetOp(d1, d2, d3), tyargs, [arg])
let mkUnionFieldGet (d1, d2, d3, tyargs, arg) = CombExpr(SumFieldGetOp(d1, d2, d3), tyargs, [arg])

let mkUnionCaseTagTest ((d1, d2), tyargs, arg) = CombExpr(SumTagTestOp(d1, d2), tyargs, [arg])
let mkUnionCaseTagTest (d1, d2, tyargs, arg) = CombExpr(SumTagTestOp(d1, d2), tyargs, [arg])

let mkTupleGet (ty, n, e) = CombExpr(TupleGetOp n, [ty], [e])

Expand Down Expand Up @@ -215,9 +213,9 @@ let mkPropGet (d, tyargs, args) = CombExpr(PropGetOp(d), tyargs, args)

let mkPropSet (d, tyargs, args) = CombExpr(PropSetOp(d), tyargs, args)

let mkFieldGet ((d1, d2), tyargs, args) = CombExpr(FieldGetOp(d1, d2), tyargs, args)
let mkFieldGet (d1, d2, tyargs, args) = CombExpr(FieldGetOp(d1, d2), tyargs, args)

let mkFieldSet ((d1, d2), tyargs, args) = CombExpr(FieldSetOp(d1, d2), tyargs, args)
let mkFieldSet (d1, d2, tyargs, args) = CombExpr(FieldSetOp(d1, d2), tyargs, args)

let mkCtorCall (d, tyargs, args) = CombExpr(CtorCallOp(d), tyargs, args)

Expand Down Expand Up @@ -409,7 +407,11 @@ let p_PropInfoData a st =
let p_CombOp x st =
match x with
| CondOp -> p_byte 0 st
| ModuleValueOp (x, y, z) -> p_byte 1 st; p_tup3 p_NamedType p_string p_bool (x, y, z) st
| ModuleValueOp (x, y, z) ->
p_byte 1 st
p_NamedType x st
p_string y st
p_bool z st
| LetRecOp -> p_byte 2 st
| RecdMkOp a -> p_byte 3 st; p_NamedType a st
| RecdGetOp (x, y) -> p_byte 4 st; p_recdFieldSpec (x, y) st
Expand Down
Loading

0 comments on commit b814ad9

Please sign in to comment.