diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 72263fc4ea4..f8b4a7487db 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -8953,26 +8953,39 @@ and TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed and TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem afterResolution delayed = let g = cenv.g let ad = env.eAccessRights - if isNil pinfos then error (InternalError ("Unexpected error: empty property list", mItem)) - // if there are both intrinsics and extensions in pinfos, intrinsics will be listed first. + + if isNil pinfos then + error (InternalError ("Unexpected error: empty property list", mItem)) + + // If there are both intrinsics and extensions in pinfos, intrinsics will be listed first. // by looking at List.Head we are letting the intrinsics determine indexed/non-indexed let pinfo = List.head pinfos + let _, tyargsOpt, args, delayed, tpenv = - if pinfo.IsIndexer - then GetMemberApplicationArgs delayed cenv env tpenv - else ExprAtomicFlag.Atomic, None, [mkSynUnit mItem], delayed, tpenv - if not pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsNotStatic nm, mItem)) + if pinfo.IsIndexer then + GetMemberApplicationArgs delayed cenv env tpenv + else + ExprAtomicFlag.Atomic, None, [mkSynUnit mItem], delayed, tpenv + + if not pinfo.IsStatic then + error (Error (FSComp.SR.tcPropertyIsNotStatic nm, mItem)) + match delayed with | DelayedSet(e2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) + // Static Property Set (possibly indexer) UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty + let meths = pinfos |> SettersOfPropInfos + if meths.IsEmpty then let meths = pinfos |> GettersOfPropInfos let isByrefMethReturnSetter = meths |> List.exists (function _,Some pinfo -> isByrefTy g (pinfo.GetPropertyType(cenv.amap,mItem)) | _ -> false) + if not isByrefMethReturnSetter then errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItem)) + // x.P <- ... byref setter if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItem)) TcMethodApplicationThen cenv env overallTy None tpenv tyargsOpt [] mItem mItem nm ad NeverMutates true meths afterResolution NormalValUse args ExprAtomicFlag.Atomic delayed @@ -9067,7 +9080,6 @@ and GetSynMemberApplicationArgs delayed tpenv = | otherDelayed -> (ExprAtomicFlag.NonAtomic, None, [], otherDelayed, tpenv) - and TcMemberTyArgsOpt cenv env tpenv tyargsOpt = match tyargsOpt with | None -> None, tpenv @@ -9233,15 +9245,15 @@ and TcEventItemThen cenv overallTy env tpenv mItem mExprAndItem objDetails (einf | None, false -> error (Error (FSComp.SR.tcEventIsNotStatic nm, mItem)) | _ -> () - let delegateType = einfo.GetDelegateType(cenv.amap, mItem) - let (SigOfFunctionForDelegate(invokeMethInfo, compiledViewOfDelArgTys, _, _)) = GetSigOfFunctionForDelegate cenv.infoReader delegateType mItem ad + let delTy = einfo.GetDelegateType(cenv.amap, mItem) + let (SigOfFunctionForDelegate(delInvokeMeth, delArgTys, _, _)) = GetSigOfFunctionForDelegate cenv.infoReader delTy mItem ad let objArgs = Option.toList (Option.map fst objDetails) - MethInfoChecks g cenv.amap true None objArgs env.eAccessRights mItem invokeMethInfo + MethInfoChecks g cenv.amap true None objArgs env.eAccessRights mItem delInvokeMeth // This checks for and drops the 'object' sender let argsTy = ArgsTypOfEventInfo cenv.infoReader mItem ad einfo - if not (slotSigHasVoidReturnTy (invokeMethInfo.GetSlotSig(cenv.amap, mItem))) then errorR (nonStandardEventError einfo.EventName mItem) - let delEventTy = mkIEventType g delegateType argsTy + if not (slotSigHasVoidReturnTy (delInvokeMeth.GetSlotSig(cenv.amap, mItem))) then errorR (nonStandardEventError einfo.EventName mItem) + let delEventTy = mkIEventType g delTy argsTy let bindObjArgs f = match objDetails with @@ -9253,17 +9265,17 @@ and TcEventItemThen cenv overallTy env tpenv mItem mExprAndItem objDetails (einf let expr = bindObjArgs (fun objVars -> // EventHelper ((fun d -> e.add_X(d)), (fun d -> e.remove_X(d)), (fun f -> new 'Delegate(f))) - mkCallCreateEvent g mItem delegateType argsTy - (let dv, de = mkCompGenLocal mItem "eventDelegate" delegateType + mkCallCreateEvent g mItem delTy argsTy + (let dv, de = mkCompGenLocal mItem "eventDelegate" delTy let callExpr, _ = BuildPossiblyConditionalMethodCall cenv env PossiblyMutates mItem false einfo.AddMethod NormalValUse [] objVars [de] mkLambda mItem dv (callExpr, g.unit_ty)) - (let dv, de = mkCompGenLocal mItem "eventDelegate" delegateType + (let dv, de = mkCompGenLocal mItem "eventDelegate" delTy let callExpr, _ = BuildPossiblyConditionalMethodCall cenv env PossiblyMutates mItem false einfo.RemoveMethod NormalValUse [] objVars [de] mkLambda mItem dv (callExpr, g.unit_ty)) (let fvty = mkFunTy g g.obj_ty (mkFunTy g argsTy g.unit_ty) let fv, fe = mkCompGenLocal mItem "callback" fvty - let createExpr = BuildNewDelegateExpr (Some einfo, g, cenv.amap, delegateType, invokeMethInfo, compiledViewOfDelArgTys, fe, fvty, mItem) - mkLambda mItem fv (createExpr, delegateType))) + let createExpr = BuildNewDelegateExpr (Some einfo, g, cenv.amap, delTy, delInvokeMeth, delArgTys, fe, fvty, mItem) + mkLambda mItem fv (createExpr, delTy))) let exprty = delEventTy PropagateThenTcDelayed cenv overallTy env tpenv mExprAndItem (MakeApplicableExprNoFlex cenv expr) exprty ExprAtomicFlag.Atomic delayed @@ -9986,23 +9998,28 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfoFo CallerArg(callerArgTy, mArg, isOpt, e'), (lambdaPropagationInfo, tpenv) -/// Typecheck "new Delegate(fun x y z -> ...)" constructs -and TcNewDelegateThen cenv (overallTy: OverallTy) env tpenv mDelTy mExprAndArg delegateTy arg atomicFlag delayed = +/// Typecheck "Delegate(fun x y z -> ...)" constructs +and TcNewDelegateThen cenv (overallTy: OverallTy) env tpenv mDelTy mExprAndArg delegateTy synArg atomicFlag delayed = let g = cenv.g let ad = env.eAccessRights - UnifyTypes cenv env mExprAndArg overallTy.Commit delegateTy - let (SigOfFunctionForDelegate(invokeMethInfo, delArgTys, _, fty)) = GetSigOfFunctionForDelegate cenv.infoReader delegateTy mDelTy ad + + let intermediateTy = if isNil delayed then overallTy.Commit else NewInferenceType g + + UnifyTypes cenv env mExprAndArg intermediateTy delegateTy + + let (SigOfFunctionForDelegate(delInvokeMeth, delArgTys, _, delFuncTy)) = GetSigOfFunctionForDelegate cenv.infoReader delegateTy mDelTy ad // We pass isInstance = true here because we're checking the rights to access the "Invoke" method - MethInfoChecks g cenv.amap true None [] env.eAccessRights mExprAndArg invokeMethInfo - let args = GetMethodArgs arg + MethInfoChecks g cenv.amap true None [] env.eAccessRights mExprAndArg delInvokeMeth - match args with - | [farg], [] -> - let m = arg.Range - let callerArg, (_, tpenv) = TcMethodArg cenv env (Array.empty, tpenv) (Array.empty, CallerArg(fty, m, false, farg)) - let expr = BuildNewDelegateExpr (None, g, cenv.amap, delegateTy, invokeMethInfo, delArgTys, callerArg.Expr, fty, m) - PropagateThenTcDelayed cenv overallTy env tpenv m (MakeApplicableExprNoFlex cenv expr) delegateTy atomicFlag delayed + let synArgs = GetMethodArgs synArg + + match synArgs with + | [synFuncArg], [] -> + let m = synArg.Range + let callerArg, (_, tpenv) = TcMethodArg cenv env (Array.empty, tpenv) (Array.empty, CallerArg(delFuncTy, m, false, synFuncArg)) + let expr = BuildNewDelegateExpr (None, g, cenv.amap, delegateTy, delInvokeMeth, delArgTys, callerArg.Expr, delFuncTy, m) + PropagateThenTcDelayed cenv overallTy env tpenv m (MakeApplicableExprNoFlex cenv expr) intermediateTy atomicFlag delayed | _ -> error(Error(FSComp.SR.tcDelegateConstructorMustBePassed(), mExprAndArg)) diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs index 8420004aaab..91ec2d3166a 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -900,38 +900,49 @@ let GetIntrinisicMostSpecificOverrideMethInfoSetsOfType (infoReader: InfoReader) /// The Invoke MethInfo, the function argument types, the function return type /// and the overall F# function type for the function type associated with a .NET delegate type [] -type SigOfFunctionForDelegate = SigOfFunctionForDelegate of MethInfo * TType list * TType * TType +type SigOfFunctionForDelegate = + SigOfFunctionForDelegate of + delInvokeMeth: MethInfo * + delArgTys: TType list * + delRetTy: TType * + delFuncTy: TType /// Given a delegate type work out the minfo, argument types, return type /// and F# function type by looking at the Invoke signature of the delegate. let GetSigOfFunctionForDelegate (infoReader: InfoReader) delty m ad = let g = infoReader.g let amap = infoReader.amap - let invokeMethInfo = + let delInvokeMeth = match GetIntrinsicMethInfosOfType infoReader (Some "Invoke") ad AllowMultiIntfInstantiations.Yes IgnoreOverrides m delty with | [h] -> h | [] -> error(Error(FSComp.SR.noInvokeMethodsFound (), m)) | h :: _ -> warning(InternalError(FSComp.SR.moreThanOneInvokeMethodFound (), m)); h let minst = [] // a delegate's Invoke method is never generic - let compiledViewOfDelArgTys = - match invokeMethInfo.GetParamTypes(amap, m, minst) with + + let delArgTys = + match delInvokeMeth.GetParamTypes(amap, m, minst) with | [args] -> args | _ -> error(Error(FSComp.SR.delegatesNotAllowedToHaveCurriedSignatures (), m)) + let fsharpViewOfDelArgTys = - match compiledViewOfDelArgTys with + match delArgTys with | [] -> [g.unit_ty] - | _ -> compiledViewOfDelArgTys - let delRetTy = invokeMethInfo.GetFSharpReturnTy(amap, m, minst) - CheckMethInfoAttributes g m None invokeMethInfo |> CommitOperationResult - let fty = mkIteratedFunTy g fsharpViewOfDelArgTys delRetTy - SigOfFunctionForDelegate(invokeMethInfo, compiledViewOfDelArgTys, delRetTy, fty) + | _ -> delArgTys + + let delRetTy = delInvokeMeth.GetFSharpReturnTy(amap, m, minst) + + CheckMethInfoAttributes g m None delInvokeMeth |> CommitOperationResult + + let delFuncTy = mkIteratedFunTy g fsharpViewOfDelArgTys delRetTy + + SigOfFunctionForDelegate(delInvokeMeth, delArgTys, delRetTy, delFuncTy) /// Try and interpret a delegate type as a "standard" .NET delegate type associated with an event, with a "sender" parameter. let TryDestStandardDelegateType (infoReader: InfoReader) m ad delTy = let g = infoReader.g - let (SigOfFunctionForDelegate(_, compiledViewOfDelArgTys, delRetTy, _)) = GetSigOfFunctionForDelegate infoReader delTy m ad - match compiledViewOfDelArgTys with + let (SigOfFunctionForDelegate(_, delArgTys, delRetTy, _)) = GetSigOfFunctionForDelegate infoReader delTy m ad + match delArgTys with | senderTy :: argTys when (isObjTy g senderTy) && not (List.exists (isByrefTy g) argTys) -> Some(mkRefTupledTy g argTys, delRetTy) | _ -> None diff --git a/src/fsharp/InfoReader.fsi b/src/fsharp/InfoReader.fsi index 3247ed7ac9e..6e1eebd234d 100644 --- a/src/fsharp/InfoReader.fsi +++ b/src/fsharp/InfoReader.fsi @@ -159,10 +159,15 @@ val TryFindIntrinsicPropInfo: infoReader:InfoReader -> m:range -> ad:AccessorDom /// Get a set of most specific override methods. val GetIntrinisicMostSpecificOverrideMethInfoSetsOfType: infoReader:InfoReader -> m:range -> ty:TType -> NameMultiMap -/// The Invoke MethInfo, the function argument types, the function return type +/// Represents information about the delegate - the Invoke MethInfo, the delegate argument types, the delegate return type /// and the overall F# function type for the function type associated with a .NET delegate type [] -type SigOfFunctionForDelegate = | SigOfFunctionForDelegate of MethInfo * TType list * TType * TType +type SigOfFunctionForDelegate = + SigOfFunctionForDelegate of + delInvokeMeth: MethInfo * + delArgTys: TType list * + delRetTy: TType * + delFuncTy: TType /// Given a delegate type work out the minfo, argument types, return type /// and F# function type by looking at the Invoke signature of the delegate. diff --git a/src/fsharp/LowerStateMachines.fs b/src/fsharp/LowerStateMachines.fs index 8319045a31d..0b6938d15b6 100644 --- a/src/fsharp/LowerStateMachines.fs +++ b/src/fsharp/LowerStateMachines.fs @@ -229,9 +229,8 @@ type LowerStateMachine(g: TcGlobals) = if sm_verbose then printfn "application was partial, reducing further args %A" laterArgs TryReduceApp env expandedExpr laterArgs - | NewDelegateExpr g (_, macroParamsCurried, macroBody, _, _) -> + | NewDelegateExpr g (_, macroParams, macroBody, _, _) -> let m = expr.Range - let macroParams = List.concat macroParamsCurried let macroVal2 = mkLambdas g m [] macroParams (macroBody, tyOfExpr g macroBody) if args.Length < macroParams.Length then //warning(Error(FSComp.SR.stateMachineMacroUnderapplied(), m)) diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 66cdd839825..79b302fa560 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -139,10 +139,10 @@ type CallerArgs<'T> = let AdjustDelegateTy (infoReader: InfoReader) actualTy reqdTy m = let g = infoReader.g - let (SigOfFunctionForDelegate(_, delArgTys, _, fty)) = GetSigOfFunctionForDelegate infoReader reqdTy m AccessibleFromSomewhere + let (SigOfFunctionForDelegate(_, delArgTys, _, delFuncTy)) = GetSigOfFunctionForDelegate infoReader reqdTy m AccessibleFromSomewhere let delArgTys = if isNil delArgTys then [g.unit_ty] else delArgTys if (fst (stripFunTy g actualTy)).Length = delArgTys.Length then - fty + delFuncTy else reqdTy @@ -1208,8 +1208,8 @@ let BuildObjCtorCall (g: TcGlobals) m = Expr.Op (TOp.ILCall (false, false, false, false, CtorValUsedAsSuperInit, false, true, ilMethRef, [], [], [g.obj_ty]), [], [], m) /// Implements the elaborated form of adhoc conversions from functions to delegates at member callsites -let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, invokeMethInfo: MethInfo, delArgTys, f, fty, m) = - let slotsig = invokeMethInfo.GetSlotSig(amap, m) +let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, delInvokeMeth: MethInfo, delArgTys, delFuncExpr, delFuncTy, m) = + let slotsig = delInvokeMeth.GetSlotSig(amap, m) let delArgVals, expr = let topValInfo = ValReprInfo([], List.replicate (max 1 (List.length delArgTys)) ValReprInfo.unnamedTopArg, ValReprInfo.unnamedRetVal) @@ -1219,7 +1219,7 @@ let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, i if Option.isSome eventInfoOpt then None else - tryDestTopLambda g amap topValInfo (f, fty) + tryDestTopLambda g amap topValInfo (delFuncExpr, delFuncTy) match lambdaContents with | None -> @@ -1238,19 +1238,19 @@ let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, i | h :: t -> [exprForVal m h; mkRefTupledVars g m t] | None -> if isNil delArgTys then [mkUnit g m] else List.map (exprForVal m) delArgVals - mkApps g ((f, fty), [], args, m) + mkApps g ((delFuncExpr, delFuncTy), [], args, m) delArgVals, expr | Some _ -> - let _, _, _, vsl, body, _ = IteratedAdjustArityOfLambda g amap topValInfo f + let _, _, _, vsl, body, _ = IteratedAdjustArityOfLambda g amap topValInfo delFuncExpr List.concat vsl, body let meth = TObjExprMethod(slotsig, [], [], [delArgVals], expr, m) mkObjExpr(delegateTy, None, BuildObjCtorCall g m, [meth], [], m) let CoerceFromFSharpFuncToDelegate g amap infoReader ad callerArgTy m callerArgExpr delegateTy = - let (SigOfFunctionForDelegate(invokeMethInfo, delArgTys, _, _)) = GetSigOfFunctionForDelegate infoReader delegateTy m ad - BuildNewDelegateExpr (None, g, amap, delegateTy, invokeMethInfo, delArgTys, callerArgExpr, callerArgTy, m) + let (SigOfFunctionForDelegate(delInvokeMeth, delArgTys, _, _)) = GetSigOfFunctionForDelegate infoReader delegateTy m ad + BuildNewDelegateExpr (None, g, amap, delegateTy, delInvokeMeth, delArgTys, callerArgExpr, callerArgTy, m) // Handle adhoc argument conversions let rec AdjustExprForTypeDirectedConversions tcVal (g: TcGlobals) amap infoReader ad reqdTy actualTy m expr = diff --git a/src/fsharp/MethodCalls.fsi b/src/fsharp/MethodCalls.fsi index 06bb066ee03..ff772370c14 100644 --- a/src/fsharp/MethodCalls.fsi +++ b/src/fsharp/MethodCalls.fsi @@ -328,7 +328,7 @@ val BuildMethodCall: val BuildObjCtorCall: g:TcGlobals -> m:range -> Expr /// Implements the elaborated form of adhoc conversions from functions to delegates at member callsites -val BuildNewDelegateExpr: eventInfoOpt:EventInfo option * g:TcGlobals * amap:ImportMap * delegateTy:TType * invokeMethInfo:MethInfo * delArgTys:TType list * f:Expr * fty:TType * m:range -> Expr +val BuildNewDelegateExpr: eventInfoOpt:EventInfo option * g:TcGlobals * amap:ImportMap * delegateTy:TType * delInvokeMeth:MethInfo * delArgTys:TType list * delFuncExpr:Expr * delFuncTy:TType * m:range -> Expr val CoerceFromFSharpFuncToDelegate: g:TcGlobals -> amap:ImportMap -> infoReader:InfoReader -> ad:AccessorDomain -> callerArgTy:TType -> m:range -> callerArgExpr:Expr -> delegateTy:TType -> Expr diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index a77d3ba75d2..e1a41014d0e 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -3897,9 +3897,9 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso if completionTargets.ResolveAll then [ for einfo in einfos do let delegateType = einfo.GetDelegateType(amap, m) - let (SigOfFunctionForDelegate(invokeMethInfo, _, _, _)) = GetSigOfFunctionForDelegate ncenv.InfoReader delegateType m ad + let (SigOfFunctionForDelegate(delInvokeMeth, _, _, _)) = GetSigOfFunctionForDelegate ncenv.InfoReader delegateType m ad // Only events with void return types are suppressed in intellisense. - if slotSigHasVoidReturnTy (invokeMethInfo.GetSlotSig(amap, m)) then + if slotSigHasVoidReturnTy (delInvokeMeth.GetSlotSig(amap, m)) then yield einfo.AddMethod.DisplayName yield einfo.RemoveMethod.DisplayName ] else [] @@ -4620,9 +4620,9 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty ( [ for einfo in einfos do let delegateType = einfo.GetDelegateType(amap, m) - let (SigOfFunctionForDelegate(invokeMethInfo, _, _, _)) = GetSigOfFunctionForDelegate ncenv.InfoReader delegateType m ad + let (SigOfFunctionForDelegate(delInvokeMeth, _, _, _)) = GetSigOfFunctionForDelegate ncenv.InfoReader delegateType m ad // Only events with void return types are suppressed in intellisense. - if slotSigHasVoidReturnTy (invokeMethInfo.GetSlotSig(amap, m)) then + if slotSigHasVoidReturnTy (delInvokeMeth.GetSlotSig(amap, m)) then yield einfo.AddMethod.DisplayName yield einfo.RemoveMethod.DisplayName ] diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index ebea5cce8b3..7df982ef510 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -1537,9 +1537,9 @@ let TryEliminateBinding cenv _env bind e2 _m = // Immediate consumption of delegate via an application in a sequential, e.g. 'let part1 = e in part1.Invoke(args); rest' // See https://github.com/fsharp/fslang-design/blob/master/tooling/FST-1034-lambda-optimizations.md - | Expr.Sequential(DebugPoints(DelegateInvokeExpr g (invokeRef, f0ty, tyargs, DebugPoints (Expr.Val (VRefLocal vspec2, _, _), recreate2), args, _), recreate1), rest, NormalSeq, m) - when IsUniqueUse vspec2 (rest :: args) -> - let invoke = MakeFSharpDelegateInvokeAndTryBetaReduce g (invokeRef, recreate2 e1, f0ty, tyargs, args, m) + | Expr.Sequential(DebugPoints(DelegateInvokeExpr g (delInvokeRef, delInvokeTy, DebugPoints (Expr.Val (VRefLocal vspec2, _, _), recreate2), delInvokeArg, _), recreate1), rest, NormalSeq, m) + when IsUniqueUse vspec2 [rest;delInvokeArg] -> + let invoke = MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, recreate2 e1, delInvokeTy, delInvokeArg, m) Some (Expr.Sequential(recreate1 invoke, rest, NormalSeq, m) |> recreate0) // Immediate consumption of value by a pattern match 'let x = e in match x with ...' @@ -2175,8 +2175,8 @@ let rec OptimizeExpr cenv (env: IncrementalOptimizationEnv) expr = | Expr.App (f, fty, tyargs, argsl, m) -> match expr with - | DelegateInvokeExpr g (iref, fty, tyargs, delegatef, args, m) -> - OptimizeFSharpDelegateInvoke cenv env (iref, delegatef, fty, tyargs, args, m) + | DelegateInvokeExpr g (delInvokeRef, delInvokeTy, delExpr, delInvokeArg, m) -> + OptimizeFSharpDelegateInvoke cenv env (delInvokeRef, delExpr, delInvokeTy, delInvokeArg, m) | _ -> let attempt = if IsDebugPipeRightExpr cenv expr then @@ -3529,17 +3529,18 @@ and OptimizeDebugPipeRights cenv env expr = pipesExprR expr, { pipesInfo with HasEffect=true} -and OptimizeFSharpDelegateInvoke cenv env (invokeRef, f0, f0ty, tyargs, args, m) = +and OptimizeFSharpDelegateInvoke cenv env (delInvokeRef, delExpr, delInvokeTy, delInvokeArg, m) = let g = cenv.g - let optf0, finfo = OptimizeExpr cenv env f0 + let optf0, finfo = OptimizeExpr cenv env delExpr - match StripPreComputationsFromComputedFunction g optf0 args (fun f argsR -> MakeFSharpDelegateInvokeAndTryBetaReduce g (invokeRef, f, f0ty, tyargs, argsR, m)) with + match StripPreComputationsFromComputedFunction g optf0 [delInvokeArg] (fun f delInvokeArgsR -> MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, f, delInvokeTy, List.head delInvokeArgsR, m)) with | Choice1Of2 remade -> OptimizeExpr cenv env remade | Choice2Of2 (newf0, remake) -> - let newArgs, arginfos = OptimizeExprsThenConsiderSplits cenv env args - let reducedExpr = MakeFSharpDelegateInvokeAndTryBetaReduce g (invokeRef, newf0, f0ty, tyargs, newArgs, m) + let newDelInvokeArgs, arginfos = OptimizeExprsThenConsiderSplits cenv env [delInvokeArg] + let newDelInvokeArg = List.head newDelInvokeArgs + let reducedExpr = MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, newf0, delInvokeTy, newDelInvokeArg, m) let newExpr = reducedExpr |> remake match newf0, reducedExpr with | Expr.Obj _, Expr.Let _ -> @@ -3553,7 +3554,6 @@ and OptimizeFSharpDelegateInvoke cenv env (invokeRef, f0, f0ty, tyargs, args, m) MightMakeCriticalTailcall = true Info=ValueOfExpr newExpr } - /// Optimize/analyze a lambda expression and OptimizeLambdas (vspec: Val option) cenv env topValInfo e ety = let g = cenv.g diff --git a/src/fsharp/TypedTreeOps.fs b/src/fsharp/TypedTreeOps.fs index ff1d0d0554e..932eb60dba6 100644 --- a/src/fsharp/TypedTreeOps.fs +++ b/src/fsharp/TypedTreeOps.fs @@ -7867,12 +7867,12 @@ let MultiLambdaToTupledLambdaIfNeeded g (vs, arg) body = let rec MakeApplicationAndBetaReduceAux g (f, fty, tyargsl: TType list list, argsl: Expr list, m) = match f with - | Expr.Let (bind, body, mlet, _) -> + | Expr.Let (bind, body, mLet, _) -> // Lift bindings out, i.e. (let x = e in f) y --> let x = e in f y // This increases the scope of 'x', which I don't like as it mucks with debugging // scopes of variables, but this is an important optimization, especially when the '|>' // notation is used a lot. - mkLetBind mlet bind (MakeApplicationAndBetaReduceAux g (body, fty, tyargsl, argsl, m)) + mkLetBind mLet bind (MakeApplicationAndBetaReduceAux g (body, fty, tyargsl, argsl, m)) | _ -> match tyargsl with | [] :: rest -> @@ -7922,14 +7922,14 @@ let MakeApplicationAndBetaReduce g (f, fty, tyargsl, argl, m) = let (|NewDelegateExpr|_|) g expr = match expr with | Expr.Obj (lambdaId, ty, a, b, [TObjExprMethod(c, d, e, tmvs, body, f)], [], m) when isDelegateTy g ty -> - Some (lambdaId, tmvs, body, m, (fun bodyR -> Expr.Obj (lambdaId, ty, a, b, [TObjExprMethod(c, d, e, tmvs, bodyR, f)], [], m))) + Some (lambdaId, List.concat tmvs, body, m, (fun bodyR -> Expr.Obj (lambdaId, ty, a, b, [TObjExprMethod(c, d, e, tmvs, bodyR, f)], [], m))) | _ -> None let (|DelegateInvokeExpr|_|) g expr = match expr with - | Expr.App ((Expr.Val (invokeRef, _, _)) as iref, fty, tyargs, (f :: args), m) - when invokeRef.LogicalName = "Invoke" && isFSharpDelegateTy g (tyOfExpr g f) -> - Some(iref, fty, tyargs, f, args, m) + | Expr.App ((Expr.Val (invokeRef, _, _)) as delInvokeRef, delInvokeTy, [], [delExpr;delInvokeArg], m) + when invokeRef.LogicalName = "Invoke" && isFSharpDelegateTy g (tyOfExpr g delExpr) -> + Some(delInvokeRef, delInvokeTy, delExpr, delInvokeArg, m) | _ -> None let (|OpPipeRight|_|) g expr = @@ -7953,19 +7953,17 @@ let (|OpPipeRight3|_|) g expr = Some(resType, arg1, arg2, arg3, fExpr, m) | _ -> None -let rec MakeFSharpDelegateInvokeAndTryBetaReduce g (invokeRef, f, fty, tyargs, argsl: Expr list, m) = - match f with - | Expr.Let (bind, body, mlet, _) -> - mkLetBind mlet bind (MakeFSharpDelegateInvokeAndTryBetaReduce g (invokeRef, body, fty, tyargs, argsl, m)) +let rec MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, delExpr, delInvokeTy, delInvokeArg, m) = + match delExpr with + | Expr.Let (bind, body, mLet, _) -> + mkLetBind mLet bind (MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, body, delInvokeTy, delInvokeArg, m)) + | NewDelegateExpr g (_, argvs, body, m, _) when argvs.Length > 0 -> + let pairs, body = MultiLambdaToTupledLambdaIfNeeded g (argvs, delInvokeArg) body + let argvs2, args2 = List.unzip pairs + mkLetsBind m (mkCompGenBinds argvs2 args2) body | _ -> - match f with - | NewDelegateExpr g (_, argvsl, body, m, _) when argvsl.Length = argsl.Length -> - let pairs, body = List.mapFoldBack (MultiLambdaToTupledLambdaIfNeeded g) (List.zip argvsl argsl) body - let argvs2, args2 = List.unzip (List.concat pairs) - mkLetsBind m (mkCompGenBinds argvs2 args2) body - | _ -> - // Remake the delegate invoke - Expr.App (invokeRef, fty, tyargs, (f :: argsl), m) + // Remake the delegate invoke + Expr.App (delInvokeRef, delInvokeTy, [], [delExpr; delInvokeArg], m) //--------------------------------------------------------------------------- // Adjust for expected usage @@ -9921,9 +9919,9 @@ let (|StructStateMachineExpr|_|) g expr = match expr with | ValApp g g.cgh__stateMachine_vref ([dataTy; _resultTy], [moveNext; setStateMachine; afterCode], _m) -> match moveNext, setStateMachine, afterCode with - | NewDelegateExpr g (_, [[moveNextThisVar]], moveNextBody, _, _), - NewDelegateExpr g (_, [[setStateMachineThisVar;setStateMachineStateVar]], setStateMachineBody, _, _), - NewDelegateExpr g (_, [[afterCodeThisVar]], afterCodeBody, _, _) -> + | NewDelegateExpr g (_, [moveNextThisVar], moveNextBody, _, _), + NewDelegateExpr g (_, [setStateMachineThisVar;setStateMachineStateVar], setStateMachineBody, _, _), + NewDelegateExpr g (_, [afterCodeThisVar], afterCodeBody, _, _) -> Some (dataTy, (moveNextThisVar, moveNextBody), (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), diff --git a/src/fsharp/TypedTreeOps.fsi b/src/fsharp/TypedTreeOps.fsi index 0b1f08daef3..234eda15703 100755 --- a/src/fsharp/TypedTreeOps.fsi +++ b/src/fsharp/TypedTreeOps.fsi @@ -1324,7 +1324,7 @@ val MakeApplicationAndBetaReduce: TcGlobals -> Expr * TType * TypeInst list * Ex /// Make a delegate invoke expression for an F# delegate type, doing beta reduction by introducing let-bindings /// if the delegate expression is a construction of a delegate. -val MakeFSharpDelegateInvokeAndTryBetaReduce: TcGlobals -> invokeRef: Expr * f: Expr * fty: TType * tyargs: TypeInst * argsl: Exprs * m: range -> Expr +val MakeFSharpDelegateInvokeAndTryBetaReduce: TcGlobals -> delInvokeRef: Expr * delExpr: Expr * delInvokeTy: TType * delInvokeArg: Expr * m: range -> Expr /// Combine two static-resolution requirements on a type parameter val JoinTyparStaticReq: TyparStaticReq -> TyparStaticReq -> TyparStaticReq @@ -2462,10 +2462,10 @@ val EmptyTraitWitnessInfoHashMap: TcGlobals -> TraitWitnessInfoHashMap<'T> val (|ValApp|_|): TcGlobals -> ValRef -> Expr -> (TypeInst * Exprs * range) option /// Match expressions that represent the creation of an instance of an F# delegate value -val (|NewDelegateExpr|_|): TcGlobals -> Expr -> (Unique * Val list list * Expr * range * (Expr -> Expr)) option +val (|NewDelegateExpr|_|): TcGlobals -> Expr -> (Unique * Val list * Expr * range * (Expr -> Expr)) option /// Match a .Invoke on a delegate -val (|DelegateInvokeExpr|_|): TcGlobals -> Expr -> (Expr * TType * TypeInst * Expr * Exprs * range) option +val (|DelegateInvokeExpr|_|): TcGlobals -> Expr -> (Expr * TType * Expr * Expr * range) option /// Match 'if __useResumableCode then ... else ...' expressions val (|IfUseResumableStateMachinesExpr|_|) : TcGlobals -> Expr -> (Expr * Expr) option diff --git a/src/fsharp/service/ServiceDeclarationLists.fs b/src/fsharp/service/ServiceDeclarationLists.fs index fdc112157d0..9d4724877f2 100644 --- a/src/fsharp/service/ServiceDeclarationLists.fs +++ b/src/fsharp/service/ServiceDeclarationLists.fs @@ -353,11 +353,11 @@ module DeclarationListHelpers = // The 'fake' representation of constructors of .NET delegate types | Item.DelegateCtor delty -> let delty, _cxs = PrettyTypes.PrettifyType g delty - let (SigOfFunctionForDelegate(_, _, _, fty)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere + let (SigOfFunctionForDelegate(_, _, _, delFuncTy)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere let layout = NicePrint.layoutTyconRef denv (tcrefOfAppTy g delty) ^^ LeftL.leftParen ^^ - NicePrint.layoutType denv fty ^^ + NicePrint.layoutType denv delFuncTy ^^ RightL.rightParen let layout = toArray layout ToolTipElement.Single(layout, xml) @@ -769,10 +769,10 @@ module internal DescriptionListsImpl = [], prettyRetTyL | Item.DelegateCtor delty -> - let (SigOfFunctionForDelegate(_, _, _, fty)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere + let (SigOfFunctionForDelegate(_, _, _, delFuncTy)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere // No need to pass more generic type information in here since the instanitations have already been applied - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst [ParamData(false, false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, fty)] delty + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst [ParamData(false, false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, delFuncTy)] delty // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group diff --git a/tests/fsharp/core/members/basics-hw/test.fsx b/tests/fsharp/core/members/basics-hw/test.fsx index 36dbb5ed1c3..06e09388906 100644 --- a/tests/fsharp/core/members/basics-hw/test.fsx +++ b/tests/fsharp/core/members/basics-hw/test.fsx @@ -2401,8 +2401,7 @@ module NameLookupServiceExample = *) - -module ConstraintsInMembers = begin +module ConstraintsInMembers = do printfn "ConstraintsInMembers" type IDuplex = @@ -2420,17 +2419,35 @@ module ConstraintsInMembers = begin type C() = member x.Bind1(v:#IDuplex) : string = bind v member x.Bind2(v:#IDuplex) : string = bind v -end -module DelegateByrefCreation = begin +module DelegateByrefCreation = type D = delegate of int byref -> int type D2 = delegate of int byref * int byref -> int let createImmediateDelegate = new D(fun b -> b) let createImmediateDelegate2 = new D2(fun b1 b2 -> b1 + b2) -end -module InterfaceCastingTests = begin + +module DelegateImmediateInvoke1 = + + type Foo = delegate of unit -> unit + + let f1 = Foo(ignore) + check "clejweljkc" (f1.Invoke()) () + +module DelegateImmediateInvoke2 = + + type Foo = delegate of unit -> unit + + check "ou309lwnkc" (Foo(ignore).Invoke()) () + +module DelegateImmediateInvoke3 = + + type Foo<'T> = delegate of 'T -> unit + + check "lceljkewjl" (Foo(ignore).Invoke(())) () + +module InterfaceCastingTests = do printfn "InterfaceCastingTests" type IBar = @@ -2506,9 +2523,6 @@ module InterfaceCastingTests = begin let checkDowncastInterfaceToUnsealedClassExplicit(l:IBar) = (downcast l : D) -end - - module MiscGenericOverrideTest = do printfn "MiscGenericOverrideTest" type 'a Class2 =