Merge pull request #9431 from dotnet/merges/master-to-release/dev16.7

Merge master to release/dev16.7

Author: KevinRansom

src/fsharp/PatternMatchCompilation.fs

@@ -7,9 +7,12 @@ open FSharp.Compiler
 open FSharp.Compiler.AbstractIL.IL
 open FSharp.Compiler.AbstractIL.Internal.Library
 open FSharp.Compiler.AbstractIL.Diagnostics
+open FSharp.Compiler.AccessibilityLogic
 open FSharp.Compiler.CompilerGlobalState
 open FSharp.Compiler.ErrorLogger
+open FSharp.Compiler.InfoReader
 open FSharp.Compiler.Lib
+open FSharp.Compiler.MethodCalls
 open FSharp.Compiler.PrettyNaming
 open FSharp.Compiler.Range
 open FSharp.Compiler.SyntaxTree
@@ -746,7 +749,7 @@ let getDiscrim (EdgeDiscrim(_, discrim, _)) = discrim
 
 
 let CompilePatternBasic
-        g denv amap exprm matchm
+        (g: TcGlobals) denv amap tcVal infoReader exprm matchm
         warnOnUnused
         warnOnIncomplete
         actionOnFailure
@@ -793,10 +796,47 @@ let CompilePatternBasic
                     mkReraise matchm resultTy
 
                 | Throw ->
-                    // We throw instead of rethrow on unmatched try-catch in a computation expression. But why?
-                    // Because this isn't a real .NET exception filter/handler but just a function we're passing
+                    let findMethInfo ty isInstance name (sigTys: TType list) =
+                        TryFindIntrinsicMethInfo infoReader matchm (AccessorDomain.AccessibleFromEverywhere) name ty
+                        |> List.tryFind (fun methInfo ->
+                            methInfo.IsInstance = isInstance &&
+                            (
+                                match methInfo.GetParamTypes(amap, matchm, []) with
+                                | [] -> false
+                                | argTysList ->
+                                    let argTys = (argTysList |> List.reduce (@)) @ [ methInfo.GetFSharpReturnTy (amap, matchm, []) ]
+                                    if argTys.Length <> sigTys.Length then
+                                        false
+                                    else
+                                        (argTys, sigTys)
+                                        ||> List.forall2 (typeEquiv g)
+                            )
+                        )
+
+                    // We use throw, or EDI.Capture(exn).Throw() when EDI is supported, instead of rethrow on unmatched try-catch in a computation expression.
+                    // But why? Because this isn't a real .NET exception filter/handler but just a function we're passing
                     // to a computation expression builder to simulate one.
-                    mkThrow matchm resultTy (exprForVal matchm origInputVal)
+                    let ediCaptureMethInfo, ediThrowMethInfo =
+                        // EDI.Capture: exn -> EDI
+                        g.system_ExceptionDispatchInfo_ty
+                        |> Option.bind (fun ty -> findMethInfo ty false "Capture" [ g.exn_ty; ty ]),
+                        // edi.Throw: unit -> unit
+                        g.system_ExceptionDispatchInfo_ty
+                        |> Option.bind (fun ty -> findMethInfo ty true "Throw" [ g.unit_ty ])
+
+                    match Option.map2 (fun x y -> x,y) ediCaptureMethInfo ediThrowMethInfo with
+                    | None ->
+                        mkThrow matchm resultTy (exprForVal matchm origInputVal)
+                    | Some (ediCaptureMethInfo, ediThrowMethInfo) ->
+                        let (edi, _) =
+                            BuildMethodCall tcVal g amap NeverMutates matchm false
+                               ediCaptureMethInfo ValUseFlag.NormalValUse [] [] [ (exprForVal matchm origInputVal) ]
+
+                        let (e, _) =
+                            BuildMethodCall tcVal g amap NeverMutates matchm false
+                                ediThrowMethInfo ValUseFlag.NormalValUse [] [edi] [ ]
+
+                        mkCompGenSequential matchm e (mkDefault (matchm, resultTy))
 
                 | ThrowIncompleteMatchException ->
                     mkThrow matchm resultTy
@@ -1335,7 +1375,7 @@ let CompilePatternBasic
 let isPartialOrWhenClause (c: TypedMatchClause) = isPatternPartial c.Pattern || c.GuardExpr.IsSome
 
 
-let rec CompilePattern  g denv amap exprm matchm warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: TypedMatchClause list) inputTy resultTy =
+let rec CompilePattern  g denv amap tcVal infoReader exprm matchm warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: TypedMatchClause list) inputTy resultTy =
     match clausesL with
     | _ when List.exists isPartialOrWhenClause clausesL ->
         // Partial clauses cause major code explosion if treated naively
@@ -1345,13 +1385,13 @@ let rec CompilePattern  g denv amap exprm matchm warnOnUnused actionOnFailure (o
         let warnOnUnused = false // we can't turn this on since we're pretending all partials fail in order to control the complexity of this.
         let warnOnIncomplete = true
         let clausesPretendAllPartialFail = List.collect (fun (TClause(p, whenOpt, tg, m)) -> [TClause(erasePartialPatterns p, whenOpt, tg, m)]) clausesL
-        let _ = CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesPretendAllPartialFail inputTy resultTy
+        let _ = CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesPretendAllPartialFail inputTy resultTy
         let warnOnIncomplete = false
 
         let rec atMostOnePartialAtATime clauses =
             match List.takeUntil isPartialOrWhenClause clauses with
             | l, [] ->
-                CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) l inputTy resultTy
+                CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) l inputTy resultTy
             | l, (h :: t) ->
                 // Add the partial clause.
                 doGroupWithAtMostOnePartial (l @ [h]) t
@@ -1372,10 +1412,10 @@ let rec CompilePattern  g denv amap exprm matchm warnOnUnused actionOnFailure (o
             // Make the clause that represents the remaining cases of the pattern match
             let clauseForRestOfMatch = TClause(TPat_wild matchm, None, TTarget(List.empty, expr, spTarget), matchm)
 
-            CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (group @ [clauseForRestOfMatch]) inputTy resultTy
+            CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (group @ [clauseForRestOfMatch]) inputTy resultTy
 
 
         atMostOnePartialAtATime clausesL
 
     | _ ->
-        CompilePatternBasic g denv amap exprm matchm warnOnUnused true actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesL inputTy resultTy
+        CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused true actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesL inputTy resultTy

src/fsharp/PatternMatchCompilation.fsi

@@ -8,6 +8,7 @@ open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeOps
 open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.Range
+open FSharp.Compiler.InfoReader
 
 /// What should the decision tree contain for any incomplete match? 
 type ActionOnFailure = 
@@ -50,7 +51,10 @@ val ilFieldToTastConst: ILFieldInit -> Const
 val internal CompilePattern: 
     TcGlobals ->
     DisplayEnv ->
-    Import.ImportMap -> 
+    Import.ImportMap ->
+    // tcVal
+    (ValRef -> ValUseFlag -> TTypes -> range -> Expr * TType) ->
+    InfoReader ->
     // range of the expression we are matching on 
     range ->  
     // range to report "incomplete match" on

src/fsharp/TcGlobals.fs

@@ -1062,6 +1062,9 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d
   member val system_MarshalByRefObject_tcref =  tryFindSysTyconRef sys "MarshalByRefObject"
   member val system_MarshalByRefObject_ty = tryMkSysNonGenericTy sys "MarshalByRefObject"
 
+  member val system_ExceptionDispatchInfo_ty =
+      tryMkSysNonGenericTy ["System"; "Runtime"; "ExceptionServices"] "ExceptionDispatchInfo"
+
   member __.system_Reflection_MethodInfo_ty = v_system_Reflection_MethodInfo_ty
 
   member val system_Array_tcref  = findSysTyconRef sys "Array"

src/fsharp/TypeChecker.fs

@@ -3249,7 +3249,7 @@ let GetMethodArgs arg =
 //------------------------------------------------------------------------- 
 
 let CompilePatternForMatch cenv (env: TcEnv) mExpr matchm warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy =
-    let dtree, targets = CompilePattern cenv.g env.DisplayEnv cenv.amap mExpr matchm warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy
+    let dtree, targets = CompilePattern cenv.g env.DisplayEnv cenv.amap (LightweightTcValForUsingInBuildMethodCall cenv.g) cenv.infoReader mExpr matchm warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy
     mkAndSimplifyMatch NoDebugPointAtInvisibleBinding mExpr matchm resultTy dtree targets
 
 /// Compile a pattern
@@ -5535,7 +5535,6 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p
                     errorR (Error (FSComp.SR.tcUnionCaseDoesNotTakeArguments (), m))
                     [], args
 
-
                 | arg :: rest when numArgTys = 1 ->
                     if numArgTys = 1 && not (List.isEmpty rest) then
                         errorR (Error (FSComp.SR.tcUnionCaseRequiresOneArgument (), m))
@@ -5544,23 +5543,24 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p
                 | [arg] -> [arg], []
 
                 | args ->
-                    errorR (Error (FSComp.SR.tcUnionCaseExpectsTupledArguments numArgTys, m))
                     [], args
 
             let args, extraPatterns =
                 let numArgs = args.Length
                 if numArgs = numArgTys then
                     args, extraPatterns
+                elif numArgs < numArgTys then
+                    if numArgTys > 1 then
+                        // Expects tuple without enough args
+                        errorR (Error (FSComp.SR.tcUnionCaseExpectsTupledArguments numArgTys, m))
+                    else                        
+                        errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m))
+                    args @ (List.init (numArgTys - numArgs) (fun _ -> SynPat.Wild (m.MakeSynthetic()))), extraPatterns
                 else
-                    if numArgs < numArgTys then
-                        if numArgs <> 0 && numArgTys <> 0 then
-                            errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m))
-                        args @ (List.init (numArgTys - numArgs) (fun _ -> SynPat.Wild (m.MakeSynthetic()))), extraPatterns
-                    else
-                        let args, remaining = args |> List.splitAt numArgTys
-                        for remainingArg in remaining do
-                            errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, remainingArg.Range))
-                        args, extraPatterns @ remaining
+                    let args, remaining = args |> List.splitAt numArgTys
+                    for remainingArg in remaining do
+                        errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, remainingArg.Range))
+                    args, extraPatterns @ remaining
 
             let extraPatterns = extraPatterns @ extraPatternsFromNames
             let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args
@@ -8571,6 +8571,7 @@ and TcComputationExpression cenv env overallTy mWhole (interpExpr: Expr) builder
 
         // 'match! expr with pats ...' --> build.Bind(e1, (function pats ...))
         | SynExpr.MatchBang (spMatch, expr, clauses, m) ->
+            let matchExpr = mkSourceExpr expr
             let mMatch = match spMatch with DebugPointAtBinding mMatch -> mMatch | _ -> m
             if isQuery then error(Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery(), mMatch))
 
@@ -8581,7 +8582,7 @@ and TcComputationExpression cenv env overallTy mWhole (interpExpr: Expr) builder
             let consumeExpr = SynExpr.MatchLambda (false, mMatch, clauses, spMatch, mMatch)
 
             // TODO: consider allowing translation to BindReturn
-            Some(translatedCtxt (mkSynCall "Bind" mMatch [expr; consumeExpr]))
+            Some(translatedCtxt (mkSynCall "Bind" mMatch [matchExpr; consumeExpr]))
 
         | SynExpr.TryWith (innerComp, _mTryToWith, clauses, _mWithToLast, mTryToLast, spTry, _spWith) ->
             let mTry = match spTry with DebugPointAtTry.Yes m -> m | _ -> mTryToLast

tests/fsharp/Compiler/CodeGen/EmittedIL/CeEdiThrow.fs

@@ -0,0 +1,54 @@
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+namespace FSharp.Compiler.UnitTests.CodeGen.EmittedIL
+
+open FSharp.Compiler.UnitTests
+open NUnit.Framework
+open FSharp.TestHelpers
+
+[<TestFixture>]
+module CeEdiThrow =
+
+    [<Test>]
+    let ``Emits EDI.Throw``() =
+        CompilerAssert.CompileLibraryAndVerifyIL
+            """
+module CE
+
+open System
+type Try() =
+    member _.Return i = i
+    member _.Delay f = f
+    member _.Run f = f()
+    member _.TryWith(body : unit -> int, catch : exn -> int) =
+        try body() with ex -> catch ex
+
+let foo = Try(){
+    try return invalidOp "Ex"
+    with :? ArgumentException -> return 1
+}
+            """
+            (fun verifier -> verifier.VerifyIL [
+            """
+  .method public strict virtual instance int32
+          Invoke(class [runtime]System.Exception _arg1) cil managed
+  {
+
+    .maxstack  5
+    .locals init (class [runtime]System.ArgumentException V_0)
+    IL_0000:  ldarg.1
+    IL_0001:  isinst     [runtime]System.ArgumentException
+    IL_0006:  stloc.0
+    IL_0007:  ldloc.0
+    IL_0008:  brfalse.s  IL_000c
+
+    IL_000a:  ldc.i4.1
+    IL_000b:  ret
+
+    IL_000c:  ldarg.1
+    IL_000d:  call       class [runtime]System.Runtime.ExceptionServices.ExceptionDispatchInfo [runtime]System.Runtime.ExceptionServices.ExceptionDispatchInfo::Capture(class [runtime]System.Exception)
+    IL_0012:  callvirt   instance void [runtime]System.Runtime.ExceptionServices.ExceptionDispatchInfo::Throw()
+    IL_0017:  ldc.i4.0
+    IL_0018:  ret
+ }
+            """
+            ])

tests/fsharp/Compiler/Language/ComputationExpressionTests.fs

@@ -7,9 +7,8 @@ open FSharp.Compiler.SourceCodeServices
 [<TestFixture>]
 module ComputationExpressionTests =
 
-    [<Test>]
-    let ``do-bang can be used with nested CE expressions``() =
-        let code = """
+    let ``complex CE with source member and applicatives`` ceUsage = 
+        sprintf """
 module Code
 type ResultBuilder() =
     member __.Return value = Ok value
@@ -29,10 +28,12 @@ module Result =
         | Ok x1res, Ok x2res -> Ok (x1res, x2res)
         | Error e, _ -> Error e
         | _, Error e -> Error e
+
     let ofChoice c =
         match c with    
         | Choice1Of2 x -> Ok x
         | Choice2Of2 x -> Error x
+
     let fold onOk onError r =
         match r with
         | Ok x -> onOk x
@@ -49,9 +50,10 @@ module Async =
     }
 
 module AsyncResult = 
-    let zip x1 x2 = 
+    let zip x1 x2 =
         Async.zip x1 x2
         |> Async.map(fun (r1, r2) -> Result.zip r1 r2)
+
     let foldResult onSuccess onError ar =
         Async.map (Result.fold onSuccess onError) ar
 
@@ -101,7 +103,7 @@ type AsyncResultBuilder() =
          compensation: unit -> unit)
         : Async<Result<'T, 'TError>> =
       async.TryFinally(computation, compensation)
-
+    
     member __.Using
         (resource: 'T when 'T :> System.IDisposable,
          binder: 'T -> Async<Result<'U, 'TError>>)
@@ -127,6 +129,7 @@ type AsyncResultBuilder() =
     
     member inline _.Source(result : Async<Result<_,_>>) : Async<Result<_,_>> = result
 
+[<AutoOpen>]
 module ARExts =
     type AsyncResultBuilder with
         /// <summary>
@@ -151,9 +154,14 @@ module ARExts =
         /// Method lets us transform data types into our internal representation.
         /// </summary>
         member inline __.Source(asyncComputation : Async<_>) : Async<Result<_,_>> = asyncComputation |> Async.map Ok
-    
+
 let asyncResult = AsyncResultBuilder()
 
+%s"""     ceUsage
+
+    [<Test>]
+    let ``do-bang can be used with nested CE expressions``() =
+        let code = ``complex CE with source member and applicatives`` """
 asyncResult {
     let! something = asyncResult { return 5 }
     do! asyncResult {
@@ -165,4 +173,21 @@ asyncResult {
 |> Async.RunSynchronously
 |> printfn "%d"
 """
-        CompilerAssert.Pass code
+        CompilerAssert.Pass code
+    
+    [<Test>]
+    let ``match-bang should apply source transformations to its inputs`` () =
+        let code = ``complex CE with source member and applicatives`` """
+asyncResult {
+    // if the source transformation is not applied, the match will not work,
+    // because match! is only defined in terms of let!, and the only
+    // bind overload provided takes AsyncResult as its input.
+    match! Ok 5 with
+    | 5 -> return "ok"
+    | n -> return! (Error (sprintf "boo %d" n))
+}
+|> AsyncResult.foldResult id (fun (err: string) -> err)
+|> Async.RunSynchronously
+|> printfn "%s"
+"""
+        CompilerAssert.Pass code

tests/fsharp/FSharpSuite.Tests.fsproj

@@ -32,6 +32,7 @@
     <Compile Include="Compiler\CodeGen\EmittedIL\LiteralValue.fs" />
     <Compile Include="Compiler\CodeGen\EmittedIL\Mutation.fs" />
     <Compile Include="Compiler\CodeGen\EmittedIL\TailCalls.fs" />
+    <Compile Include="Compiler\CodeGen\EmittedIL\CeEdiThrow.fs" />
     <Compile Include="Compiler\Conformance\DataExpressions\ComputationExpressions.fs" />
     <Compile Include="Compiler\Conformance\BasicGrammarElements\BasicConstants.fs" />
     <Compile Include="Compiler\ErrorMessages\ConstructorTests.fs" />

tests/service/PatternMatchCompilationTests.fs

@@ -80,7 +80,7 @@ match A with
 """
     assertHasSymbolUsages ["x"; "y"] checkResults
     dumpErrors checkResults |> shouldEqual [
-        "(7,2--7,10): This constructor is applied to 2 argument(s) but expects 3"
+        "(7,2--7,10): This union case expects 3 arguments in tupled form"        
         "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)."
     ]
 
@@ -257,6 +257,23 @@ match TraceLevel.Off with
     ]
 
 
+[<Test>]
+let ``Caseless DU`` () =
+    let _, checkResults = getParseAndCheckResults """
+type DU = Case of int
+
+let f du =
+    match du with
+    | Case -> ()
+
+let dowork () =
+    f (Case 1)
+    0 // return an integer exit code"""
+    assertHasSymbolUsages ["DU"; "dowork"; "du"; "f"] checkResults
+    dumpErrors checkResults |> shouldEqual [
+        "(6,6--6,10): This constructor is applied to 0 argument(s) but expects 1"
+    ]
+    
 [<Test>]
 let ``Or 01 - No errors`` () =
     let _, checkResults = getParseAndCheckResults """