From 0f72bfdf9930883e2ce4ff66ef6399a706990954 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 7 Feb 2020 11:25:03 +0000 Subject: [PATCH] cleanup and pre-prep for https://github.com/dotnet/fsharp/pull/6810 --- src/fsharp/ConstraintSolver.fs | 128 +++-------------------------- src/fsharp/IlxGen.fs | 15 +--- src/fsharp/MethodCalls.fs | 123 +++++++++++++++++++++++++++ src/fsharp/PostInferenceChecks.fs | 17 ++-- src/fsharp/QuotationPickler.fs | 22 ++--- src/fsharp/QuotationPickler.fsi | 16 ++-- src/fsharp/QuotationTranslator.fs | 80 ++++++++++++------ src/fsharp/QuotationTranslator.fsi | 10 +-- 8 files changed, 219 insertions(+), 192 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 08d130a5099..00460eab9ef 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -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 = diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 5d18e0d5497..b29d597bbfd 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -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 @@ -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 diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 0557dc38c9c..09441aa6e65 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -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 diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 35bf453212c..6a675eb566e 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -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) @@ -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 diff --git a/src/fsharp/QuotationPickler.fs b/src/fsharp/QuotationPickler.fs index 82273b01ab7..0929b14f6c5 100644 --- a/src/fsharp/QuotationPickler.fs +++ b/src/fsharp/QuotationPickler.fs @@ -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 = @@ -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]) @@ -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) @@ -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 diff --git a/src/fsharp/QuotationPickler.fsi b/src/fsharp/QuotationPickler.fsi index ffe23215886..f5a408e7d6f 100644 --- a/src/fsharp/QuotationPickler.fsi +++ b/src/fsharp/QuotationPickler.fsi @@ -51,8 +51,6 @@ type MethodBaseData = | Method of MethodData | Ctor of CtorData -type FieldData = NamedTypeData * string -type RecdFieldData = NamedTypeData * string type PropInfoData = NamedTypeData * string * TypeData * TypeData list val mkVar : int -> ExprData @@ -67,11 +65,11 @@ val mkModuleValueApp : NamedTypeData * string * bool * TypeData list * ExprData val mkLetRec : (VarData * ExprData) list * ExprData -> ExprData val mkLet : (VarData * ExprData) * ExprData -> ExprData val mkRecdMk : NamedTypeData * TypeData list * ExprData list -> ExprData -val mkRecdGet : RecdFieldData * TypeData list * ExprData list -> ExprData -val mkRecdSet : RecdFieldData * TypeData list * ExprData list -> ExprData -val mkUnion : (NamedTypeData * string) * TypeData list * ExprData list -> ExprData -val mkUnionFieldGet : (NamedTypeData * string * int) * TypeData list * ExprData -> ExprData -val mkUnionCaseTagTest : (NamedTypeData * string) * TypeData list * ExprData -> ExprData +val mkRecdGet : NamedTypeData * string * TypeData list * ExprData list -> ExprData +val mkRecdSet : NamedTypeData * string * TypeData list * ExprData list -> ExprData +val mkUnion : NamedTypeData * string * TypeData list * ExprData list -> ExprData +val mkUnionFieldGet : NamedTypeData * string * int * TypeData list * ExprData -> ExprData +val mkUnionCaseTagTest : NamedTypeData * string * TypeData list * ExprData -> ExprData val mkTuple : TypeData * ExprData list -> ExprData val mkTupleGet : TypeData * int * ExprData -> ExprData val mkCoerce : TypeData * ExprData -> ExprData @@ -104,8 +102,8 @@ val mkTryWith : ExprData * VarData * ExprData * VarData * ExprData -> ExprData val mkDelegate : TypeData * ExprData -> ExprData val mkPropGet : PropInfoData * TypeData list * ExprData list -> ExprData val mkPropSet : PropInfoData * TypeData list * ExprData list -> ExprData -val mkFieldGet : FieldData * TypeData list * ExprData list -> ExprData -val mkFieldSet : FieldData * TypeData list * ExprData list -> ExprData +val mkFieldGet : NamedTypeData * string * TypeData list * ExprData list -> ExprData +val mkFieldSet : NamedTypeData * string * TypeData list * ExprData list -> ExprData val mkCtorCall : CtorData * TypeData list * ExprData list -> ExprData val mkMethodCall : MethodData * TypeData list * ExprData list -> ExprData val mkAttributedExpression : ExprData * ExprData -> ExprData diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 879130ab74e..debc8c666b3 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -414,16 +414,16 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. | Expr.Op (op, tyargs, args, m) -> match op, tyargs, args with | TOp.UnionCase ucref, _, _ -> - let mkR = ConvUnionCaseRef cenv ucref m + let tcR, s = ConvUnionCaseRef cenv ucref m let tyargsR = ConvTypes cenv env m tyargs let argsR = ConvExprs cenv env args - QP.mkUnion(mkR, tyargsR, argsR) + QP.mkUnion(tcR, s, tyargsR, argsR) | TOp.Tuple tupInfo, tyargs, _ -> let tyR = ConvType cenv env m (mkAnyTupledTy cenv.g tupInfo tyargs) let argsR = ConvExprs cenv env args - QP.mkTuple(tyR, argsR) // TODO: propagate to quotations + QP.mkTuple(tyR, argsR) | TOp.Recd (_, tcref), _, _ -> let rgtypR = ConvTyconRef cenv tcref m @@ -443,7 +443,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. let rgtypR = ConvILTypeRef cenv tref let tyargsR = ConvTypes cenv env m tyargs let argsR = ConvExprs cenv env args - QP.mkRecdGet((rgtypR, anonInfo.SortedNames.[n]), tyargsR, argsR) + QP.mkRecdGet(rgtypR, anonInfo.SortedNames.[n], tyargsR, argsR) | TOp.UnionCaseFieldGet (ucref, n), tyargs, [e] -> ConvUnionFieldGet cenv env m ucref n tyargs e @@ -475,7 +475,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. let tyargsR = ConvTypes cenv env m enclTypeArgs let parentTyconR = ConvILTypeRefUnadjusted cenv m fspec.DeclaringTypeRef let argsR = ConvLValueArgs cenv env args - QP.mkFieldSet( (parentTyconR, fspec.Name), tyargsR, argsR) + QP.mkFieldSet(parentTyconR, fspec.Name, tyargsR, argsR) | TOp.ILAsm ([ AI_ceq ], _), _, [arg1;arg2] -> let ty = tyOfExpr cenv.g arg1 @@ -506,15 +506,15 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. | TOp.ValFieldSet rfref, _tinst, args -> let argsR = ConvLValueArgs cenv env args let tyargsR = ConvTypes cenv env m tyargs - let ((_parentTyconR, fldOrPropName) as projR) = ConvRecdFieldRef cenv rfref m + let parentTyconR, fldOrPropName = ConvRecdFieldRef cenv rfref m if rfref.TyconRef.IsRecordTycon then - QP.mkRecdSet(projR, tyargsR, argsR) + QP.mkRecdSet(parentTyconR, fldOrPropName, tyargsR, argsR) else let fspec = rfref.RecdField let tcref = rfref.TyconRef let parentTyconR = ConvTyconRef cenv tcref m if useGenuineField tcref.Deref fspec then - QP.mkFieldSet( projR, tyargsR, argsR) + QP.mkFieldSet(parentTyconR, fldOrPropName, tyargsR, argsR) else let envinner = BindFormalTypars env (tcref.TyparsNoRange) let propRetTypeR = ConvType cenv envinner m fspec.FormalType @@ -604,12 +604,24 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. | TOp.UInt16s arr, [], [] -> ConvExpr cenv env (Expr.Op (TOp.Array, [cenv.g.uint16_ty], List.ofArray (Array.map (mkUInt16 cenv.g m) arr), m)) - | TOp.UnionCaseProof _, _, [e] -> ConvExpr cenv env e // Note: we erase the union case proof conversions when converting to quotations - | TOp.UnionCaseTagGet _tycr, _tinst, [_cx] -> wfail(Error(FSComp.SR.crefQuotationsCantFetchUnionIndexes(), m)) - | TOp.UnionCaseFieldSet (_c, _i), _tinst, [_cx;_x] -> wfail(Error(FSComp.SR.crefQuotationsCantSetUnionFields(), m)) - | TOp.ExnFieldSet (_tcref, _i), [], [_ex;_x] -> wfail(Error(FSComp.SR.crefQuotationsCantSetExceptionFields(), m)) - | TOp.RefAddrGet _, _, _ -> wfail(Error(FSComp.SR.crefQuotationsCantRequireByref(), m)) - | TOp.TraitCall (_ss), _, _ -> wfail(Error(FSComp.SR.crefQuotationsCantCallTraitMembers(), m)) + | TOp.UnionCaseProof _, _, [e] -> + ConvExpr cenv env e // Note: we erase the union case proof conversions when converting to quotations + + | TOp.UnionCaseTagGet _tycr, _tinst, [_cx] -> + wfail(Error(FSComp.SR.crefQuotationsCantFetchUnionIndexes(), m)) + + | TOp.UnionCaseFieldSet (_c, _i), _tinst, [_cx;_x] -> + wfail(Error(FSComp.SR.crefQuotationsCantSetUnionFields(), m)) + + | TOp.ExnFieldSet (_tcref, _i), [], [_ex;_x] -> + wfail(Error(FSComp.SR.crefQuotationsCantSetExceptionFields(), m)) + + | TOp.RefAddrGet _, _, _ -> + wfail(Error(FSComp.SR.crefQuotationsCantRequireByref(), m)) + + | TOp.TraitCall (_ss), _, _ -> + wfail(Error(FSComp.SR.crefQuotationsCantCallTraitMembers(), m)) + | _ -> wfail(InternalError( "Unexpected expression shape", m)) @@ -620,14 +632,13 @@ and ConvLdfld cenv env m (fspec: ILFieldSpec) enclTypeArgs args = let tyargsR = ConvTypes cenv env m enclTypeArgs let parentTyconR = ConvILTypeRefUnadjusted cenv m fspec.DeclaringTypeRef let argsR = ConvLValueArgs cenv env args - QP.mkFieldGet( (parentTyconR, fspec.Name), tyargsR, argsR) + QP.mkFieldGet(parentTyconR, fspec.Name, tyargsR, argsR) and ConvUnionFieldGet cenv env m ucref n tyargs e = let tyargsR = ConvTypes cenv env m tyargs let tcR, s = ConvUnionCaseRef cenv ucref m - let projR = (tcR, s, n) let eR = ConvLValueExpr cenv env e - QP.mkUnionFieldGet(projR, tyargsR, eR) + QP.mkUnionFieldGet(tcR, s, n, tyargsR, eR) and ConvClassOrRecdFieldGet cenv env m rfref tyargs args = EmitDebugInfoIfNecessary cenv env m (ConvClassOrRecdFieldGetCore cenv env m rfref tyargs args) @@ -635,14 +646,14 @@ and ConvClassOrRecdFieldGet cenv env m rfref tyargs args = and private ConvClassOrRecdFieldGetCore cenv env m rfref tyargs args = let tyargsR = ConvTypes cenv env m tyargs let argsR = ConvLValueArgs cenv env args - let ((parentTyconR, fldOrPropName) as projR) = ConvRecdFieldRef cenv rfref m + let (parentTyconR, fldOrPropName) = ConvRecdFieldRef cenv rfref m if rfref.TyconRef.IsRecordTycon then - QP.mkRecdGet(projR, tyargsR, argsR) + QP.mkRecdGet(parentTyconR, fldOrPropName, tyargsR, argsR) else let fspec = rfref.RecdField let tcref = rfref.TyconRef if useGenuineField tcref.Deref fspec then - QP.mkFieldGet(projR, tyargsR, argsR) + QP.mkFieldGet(parentTyconR, fldOrPropName, tyargsR, argsR) else let envinner = BindFormalTypars env tcref.TyparsNoRange let propRetTypeR = ConvType cenv envinner m fspec.FormalType @@ -881,9 +892,9 @@ and ConvDecisionTree cenv env tgs typR x = match discrim with | DecisionTreeTest.UnionCase (ucref, tyargs) -> let e1R = ConvLValueExpr cenv env e1 - let ucR = ConvUnionCaseRef cenv ucref m + let tcR, s = ConvUnionCaseRef cenv ucref m let tyargsR = ConvTypes cenv env m tyargs - QP.mkCond (QP.mkUnionCaseTagTest (ucR, tyargsR, e1R), ConvDecisionTree cenv env tgs typR dtree, acc) + QP.mkCond (QP.mkUnionCaseTagTest (tcR, s, tyargsR, e1R), ConvDecisionTree cenv env tgs typR dtree, acc) | DecisionTreeTest.Const (Const.Bool true) -> let e1R = ConvExpr cenv env e1 @@ -1043,7 +1054,8 @@ and ConvReturnType cenv envinner m retTy = | None -> ConvVoidType cenv m | Some ty -> ConvType cenv envinner m ty -let ConvExprPublic cenv env e = +let ConvExprPublic cenv e = + let env = QuotationTranslationEnv.Empty let astExpr = let astExpr = ConvExpr cenv env e // always emit debug info for the top level expression @@ -1108,6 +1120,24 @@ let ConvMethodBase cenv env (methName, v: Val) = Module = parentTyconR IsProperty = IsCompiledAsStaticProperty cenv.g v } +let ConvReflectedDefinition cenv methName v e = + let g = cenv.g + let ety = tyOfExpr g e + let tps, taue, _ = + match e with + | Expr.TyLambda (_, tps, body, _, _) -> tps, body, applyForallTy g ety (List.map mkTyparTy tps) + | _ -> [], e, ety + let env = QuotationTranslationEnv.Empty + let env = env.BindTypars tps + let astExpr = + let astExpr = ConvExpr cenv env taue + // always emit debug info for ReflectedDefinition expression + let old = cenv.emitDebugInfoInQuotations + try + cenv.emitDebugInfoInQuotations <- true + EmitDebugInfoIfNecessary cenv env e.Range astExpr + finally + cenv.emitDebugInfoInQuotations <- old -// FSComp.SR.crefQuotationsCantContainLiteralByteArrays - + let mbaseR = ConvMethodBase cenv env (methName, v) + mbaseR, astExpr diff --git a/src/fsharp/QuotationTranslator.fsi b/src/fsharp/QuotationTranslator.fsi index 184f1d3da4e..533f0875c3a 100755 --- a/src/fsharp/QuotationTranslator.fsi +++ b/src/fsharp/QuotationTranslator.fsi @@ -11,11 +11,6 @@ open FSharp.Compiler.Tast open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL -[] -type QuotationTranslationEnv = - static member Empty : QuotationTranslationEnv - member BindTypars : Typars -> QuotationTranslationEnv - exception InvalidQuotedTerm of exn exception IgnoringPartOfQuotedTermWarning of string * Range.range @@ -36,9 +31,8 @@ type QuotationGenerationScope = member Close: unit -> ILTypeRef list * (TType * range) list * (Expr * range) list static member ComputeQuotationFormat : TcGlobals -> QuotationSerializationFormat -val ConvExprPublic : QuotationGenerationScope -> QuotationTranslationEnv -> Expr -> QuotationPickler.ExprData -val ConvMethodBase : QuotationGenerationScope -> QuotationTranslationEnv -> string * Val -> QuotationPickler.MethodBaseData - +val ConvExprPublic : QuotationGenerationScope -> Expr -> QuotationPickler.ExprData +val ConvReflectedDefinition: QuotationGenerationScope -> string -> Val -> Expr -> QuotationPickler.MethodBaseData * QuotationPickler.ExprData val (|ModuleValueOrMemberUse|_|) : TcGlobals -> Expr -> (ValRef * ValUseFlag * Expr * TType * TypeInst * Expr list) option val (|SimpleArrayLoopUpperBound|_|) : Expr -> unit option