Witnesses made visible in FCS (dotnet#9510)

Co-authored-by: Don Syme <[email protected]>

Author: 2 people

src/fsharp/AttributeChecking.fs

@@ -79,6 +79,11 @@ type AttribInfo =
     | FSAttribInfo of TcGlobals * Attrib
     | ILAttribInfo of TcGlobals * Import.ImportMap * ILScopeRef * ILAttribute * range
 
+    member x.Range = 
+         match x with 
+         | FSAttribInfo(_, attrib) -> attrib.Range
+         | ILAttribInfo (_, _, _, _, m) -> m
+
     member x.TyconRef = 
          match x with 
          | FSAttribInfo(_g, Attrib(tcref, _, _, _, _, _, _)) -> tcref

src/fsharp/MethodCalls.fs

@@ -1864,13 +1864,21 @@ let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =
             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
+
+            // For methods taking no arguments, 'argExprs' will be a single unit expression here
+            let argExprs = 
+                 match argTypes, argExprs with
+                 | [], [_] -> []
+                 | _ -> argExprs
+
             let convertedArgs = (argExprs, argTypes) ||> List.map2 (fun expr expectedTy -> mkCoerceIfNeeded g expectedTy (tyOfExpr g expr) expr)
             match receiverArgOpt with
             | Some r -> r :: convertedArgs

src/fsharp/TypedTree.fs

@@ -4115,6 +4115,8 @@ type Attrib =
 
     member x.TyconRef = (let (Attrib(tcref, _, _, _, _, _, _)) = x in tcref)
 
+    member x.Range = (let (Attrib(_, _, _, _, _, _, m)) = x in m)
+
     override x.ToString() = "attrib" + x.TyconRef.ToString()
 
 /// We keep both source expression and evaluated expression around to help intellisense and signature printing

src/fsharp/TypedTreeOps.fs

@@ -4237,9 +4237,12 @@ let ComputeRemappingFromInferredSignatureToExplicitSignature g mty msigty =
 /// At TMDefRec nodes abstract (virtual) vslots are effectively binders, even 
 /// though they are tucked away inside the tycon. This helper function extracts the
 /// virtual slots to aid with finding this babies.
-let abstractSlotValsOfTycons (tycons: Tycon list) =  
+let abstractSlotValRefsOfTycons (tycons: Tycon list) =  
     tycons 
     |> List.collect (fun tycon -> if tycon.IsFSharpObjectModelTycon then tycon.FSharpObjectModelTypeInfo.fsobjmodel_vslots else []) 
+
+let abstractSlotValsOfTycons (tycons: Tycon list) =  
+    abstractSlotValRefsOfTycons tycons 
     |> List.map (fun v -> v.Deref)
 
 let rec accEntityRemapFromModuleOrNamespace msigty x acc = 

src/fsharp/TypedTreeOps.fsi

@@ -1043,6 +1043,8 @@ module SimplifyTypes =
 
 val superOfTycon : TcGlobals -> Tycon -> TType
 
+val abstractSlotValRefsOfTycons : Tycon list -> ValRef list
+
 val abstractSlotValsOfTycons : Tycon list -> Val list
 
 //-------------------------------------------------------------------------

src/fsharp/symbols/Exprs.fs

@@ -5,6 +5,7 @@ namespace FSharp.Compiler.SourceCodeServices
 open FSharp.Compiler
 open FSharp.Compiler.AbstractIL.Internal.Library
 open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.ErrorLogger
 open FSharp.Compiler.Lib
 open FSharp.Compiler.Infos
 open FSharp.Compiler.QuotationTranslator
@@ -35,13 +36,26 @@ module ExprTranslationImpl =
           isinstVals: ValMap<TType * Expr> 
 
           substVals: ValMap<Expr>
+
+          /// Indicates that we disable generation of witnesses
+          suppressWitnesses: bool
+
+          /// All witnesses in scope and their mapping to lambda variables.
+          //
+          // Note: this uses an immutable HashMap/Dictionary with an IEqualityComparer that captures TcGlobals, see
+          // the point where the empty initial object is created.
+          witnessesInScope: TraitWitnessInfoHashMap<int>
+
         }
 
-        static member Empty = 
+        static member Empty g = 
             { vs=ValMap<_>.Empty
-              tyvs = Map.empty ;
+              tyvs = Map.empty
               isinstVals = ValMap<_>.Empty 
-              substVals = ValMap<_>.Empty }
+              substVals = ValMap<_>.Empty
+              suppressWitnesses = false
+              witnessesInScope = EmptyTraitWitnessInfoHashMap g
+            }
 
         member env.BindTypar (v: Typar, gp) = 
             { env with tyvs = env.tyvs.Add(v.Stamp, gp ) }
@@ -81,7 +95,7 @@ type E =
     | IfThenElse   of FSharpExpr * FSharpExpr * FSharpExpr  
     | DecisionTree   of FSharpExpr * (FSharpMemberOrFunctionOrValue list * FSharpExpr) list
     | DecisionTreeSuccess of int * FSharpExpr list
-    | Call of FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list 
+    | Call of FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list * FSharpExpr list 
     | NewObject of FSharpMemberOrFunctionOrValue * FSharpType list * FSharpExpr list 
     | LetRec of ( FSharpMemberOrFunctionOrValue * FSharpExpr) list * FSharpExpr  
     | Let of (FSharpMemberOrFunctionOrValue * FSharpExpr) * FSharpExpr 
@@ -117,6 +131,7 @@ type E =
     | ILFieldGet of FSharpExpr option * FSharpType * string 
     | ILFieldSet of FSharpExpr option * FSharpType * string  * FSharpExpr 
     | ILAsm of string * FSharpType list * FSharpExpr list
+    | WitnessArg of int
 
 /// Used to represent the information at an object expression member 
 and [<Sealed>]  FSharpObjectExprOverride(sgn: FSharpAbstractSignature, gps: FSharpGenericParameter list, args: FSharpMemberOrFunctionOrValue list list, body: FSharpExpr) = 
@@ -128,10 +143,11 @@ and [<Sealed>]  FSharpObjectExprOverride(sgn: FSharpAbstractSignature, gps: FSha
 /// The type of expressions provided through the compiler API.
 and [<Sealed>] FSharpExpr (cenv, f: (unit -> FSharpExpr) option, e: E, m: range, ty) =
 
+    let mutable e = match f with None -> e | Some _ -> Unchecked.defaultof<E>
     member x.Range = m
     member x.Type = FSharpType(cenv, ty)
     member x.cenv = cenv
-    member x.E = match f with None -> e | Some f -> f().E
+    member x.E = match box e with null -> (e <- f.Value().E); e | _ -> e
     override x.ToString() = sprintf "%+A" x.E
 
     member x.ImmediateSubExpressions = 
@@ -150,7 +166,7 @@ and [<Sealed>] FSharpExpr (cenv, f: (unit -> FSharpExpr) option, e: E, m: range,
         | E.NewUnionCase (_unionType, _unionCase, es) -> es
         | E.NewTuple (_tupleType, es) -> es
         | E.TupleGet (_tupleType, _itemIndex, tupleExpr) -> [tupleExpr]
-        | E.Call (objOpt, _b, _c, _d, es) -> (match objOpt with None -> es | Some x -> x :: es)
+        | E.Call (objOpt, _b, _c, _d, ws, es) -> (match objOpt with None -> ws @ es | Some x -> x :: ws @ es)
         | E.NewObject (_a, _b, c) -> c
         | E.FSharpFieldGet (objOpt, _b, _c) -> (match objOpt with None -> [] | Some x -> [x])
         | E.FSharpFieldSet (objOpt, _b, _c, d) -> (match objOpt with None -> [d] | Some x -> [x;d])
@@ -187,7 +203,7 @@ and [<Sealed>] FSharpExpr (cenv, f: (unit -> FSharpExpr) option, e: E, m: range,
         | E.UnionCaseSet (obj, _unionType, _unionCase, _unionField, valueExpr) -> [ yield obj; yield valueExpr ]
         | E.TraitCall (_sourceTypes, _traitName, _memberFlags, _paramTypes, _retTypes, args) -> args
         | E.Unused -> [] // unexpected
-
+        | E.WitnessArg _n -> []
 
 /// The implementation of the conversion operation
 module FSharpExprConvert =
@@ -409,19 +425,19 @@ module FSharpExprConvert =
         let (numEnclTypeArgs, _, isNewObj, _valUseFlags, _isSelfInit, takesInstanceArg, _isPropGet, _isPropSet) = 
             GetMemberCallInfo cenv.g (vref, vFlags)
 
-        let isMember, curriedArgInfos = 
+        let isMember, tps, curriedArgInfos = 
 
             match vref.MemberInfo with 
             | Some _ when not vref.IsExtensionMember -> 
                 // This is an application of a member method
                 // We only count one argument block for these.
-                let _tps, curriedArgInfos, _, _ = GetTypeOfMemberInFSharpForm cenv.g vref 
-                true, curriedArgInfos
+                let tps, curriedArgInfos, _, _ = GetTypeOfMemberInFSharpForm cenv.g vref 
+                true, tps, curriedArgInfos
             | _ -> 
                 // This is an application of a module value or extension member
                 let arities = arityOfVal vref.Deref 
-                let _tps, curriedArgInfos, _, _ = GetTopValTypeInFSharpForm cenv.g arities vref.Type m
-                false, curriedArgInfos
+                let tps, curriedArgInfos, _, _ = GetTopValTypeInFSharpForm cenv.g arities vref.Type m
+                false, tps, curriedArgInfos
 
         // Compute the object arguments as they appear in a compiled call
         // Strip off the object argument, if any. The curriedArgInfos are already adjusted to compiled member form
@@ -467,12 +483,35 @@ module FSharpExprConvert =
             if isMember then 
                 let callArgs = (objArgs :: untupledCurriedArgs) |> List.concat
                 let enclTyArgs, methTyArgs = List.splitAfter numEnclTypeArgs tyargs
+                let witnessArgsR = GetWitnessArgs cenv env vref m tps tyargs
                 // tailcall
-                ConvObjectModelCallLinear cenv env (isNewObj, FSharpMemberOrFunctionOrValue(cenv, vref), enclTyArgs, methTyArgs, callArgs) contf2
+                ConvObjectModelCallLinear cenv env (isNewObj, FSharpMemberOrFunctionOrValue(cenv, vref), enclTyArgs, methTyArgs, witnessArgsR, callArgs) contf2
             else
                 let v = FSharpMemberOrFunctionOrValue(cenv, vref)
+                let witnessArgsR = GetWitnessArgs cenv env vref m vref.Typars tyargs
                 // tailcall
-                ConvObjectModelCallLinear cenv env (false, v, [], tyargs, List.concat untupledCurriedArgs) contf2
+                ConvObjectModelCallLinear cenv env (false, v, [], tyargs, witnessArgsR, List.concat untupledCurriedArgs) contf2
+
+    and GetWitnessArgs cenv (env: ExprTranslationEnv) (vref: ValRef) m tps tyargs : FSharpExpr list =
+        let g = cenv.g
+        if cenv.g.langVersion.SupportsFeature(Features.LanguageFeature.WitnessPassing) && not env.suppressWitnesses then 
+            let witnessExprs = 
+                match ConstraintSolver.CodegenWitnessesForTyparInst cenv.tcValF g cenv.amap m tps tyargs with
+                // There is a case where optimized code makes expressions that do a shift-left on the 'char'
+                // type.  There is no witness for this case.  This is due to the code
+                //    let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #)
+                // in FSharp.Core. 
+                | ErrorResult _  when vref.LogicalName =  "op_LeftShift" && tyargs.Length = 1 -> []
+                | res -> CommitOperationResult res
+            let env = { env with suppressWitnesses = true }
+            witnessExprs |> List.map (fun arg -> 
+                match arg with 
+                | Choice1Of2 traitInfo -> 
+                    ConvWitnessInfo cenv env m traitInfo
+                | Choice2Of2 arg -> 
+                    ConvExpr cenv env arg) 
+        else
+            []
 
     and ConvExprPrim (cenv: SymbolEnv) (env: ExprTranslationEnv) expr = 
         // Eliminate integer 'for' loops 
@@ -554,7 +593,7 @@ module FSharpExprConvert =
                     let vslR = List.map (List.map (ConvVal cenv)) tmvs 
                     let sgn = FSharpAbstractSignature(cenv, slotsig)
                     let tpsR = [ for tp in tps -> FSharpGenericParameter(cenv, tp) ]
-                    let env = ExprTranslationEnv.Empty.BindTypars (Seq.zip tps tpsR |> Seq.toList)
+                    let env = env.BindTypars (Seq.zip tps tpsR |> Seq.toList)
                     let env = env.BindCurriedVals tmvs
                     let bodyR = ConvExpr cenv env body
                     FSharpObjectExprOverride(sgn, tpsR, vslR, bodyR) ]
@@ -841,9 +880,29 @@ module FSharpExprConvert =
                 ConvExprPrim cenv env replExpr
 
             | _ -> wfail (sprintf "unhandled construct in AST", m)
+        | Expr.WitnessArg (traitInfo, _m) ->
+            ConvWitnessInfoPrim cenv env traitInfo
         | _ -> 
             wfail (sprintf "unhandled construct in AST", expr.Range)
 
+    and ConvWitnessInfoPrim _cenv env traitInfo : E =
+        let witnessInfo = traitInfo.TraitKey
+        let env = { env with suppressWitnesses = true }
+        // First check if this is a witness in ReflectedDefinition code
+        if env.witnessesInScope.ContainsKey witnessInfo then 
+            let witnessArgIdx = env.witnessesInScope.[witnessInfo]
+            E.WitnessArg(witnessArgIdx)
+        // Otherwise it is a witness in a quotation literal 
+        else
+            //failwith "witness not found"
+            E.WitnessArg(-1)
+
+    and ConvWitnessInfo cenv env m traitInfo : FSharpExpr =
+        let g = cenv.g
+        let witnessInfo = traitInfo.TraitKey
+        let witnessTy = GenWitnessTy g witnessInfo 
+        let traitInfoR = ConvWitnessInfoPrim cenv env traitInfo
+        Mk cenv m witnessTy traitInfoR
 
     and ConvLetBind cenv env (bind : Binding) = 
         match bind.Expr with 
@@ -895,7 +954,7 @@ module FSharpExprConvert =
         let enclosingType = generalizedTyconRef tcref
 
         let makeCall minfo =
-            ConvObjectModelCallLinear cenv env (isNewObj, minfo, enclTypeArgs, methTypeArgs, callArgs) id   
+            ConvObjectModelCallLinear cenv env (isNewObj, minfo, enclTypeArgs, methTypeArgs, [], callArgs) id   
 
         let makeFSCall isMember (vr: ValRef) =
             let memOrVal =
@@ -1079,7 +1138,7 @@ module FSharpExprConvert =
           with e -> 
             failwithf "An IL call to '%s' could not be resolved: %s" (ilMethRef.ToString()) e.Message
 
-    and ConvObjectModelCallLinear cenv env (isNewObj, v: FSharpMemberOrFunctionOrValue, enclTyArgs, methTyArgs, callArgs) contF =
+    and ConvObjectModelCallLinear cenv env (isNewObj, v: FSharpMemberOrFunctionOrValue, enclTyArgs, methTyArgs, witnessArgsR: FSharpExpr list, callArgs) contF =
         let enclTyArgsR = ConvTypes cenv enclTyArgs
         let methTyArgsR = ConvTypes cenv methTyArgs
         let obj, callArgs = 
@@ -1095,8 +1154,7 @@ module FSharpExprConvert =
             if isNewObj then 
                 E.NewObject(v, enclTyArgsR, callArgsR) 
             else 
-                E.Call(objR, v, enclTyArgsR, methTyArgsR, callArgsR))
-
+                E.Call(objR, v, enclTyArgsR, methTyArgsR, witnessArgsR, callArgsR))
 
     and ConvExprs cenv env args = List.map (ConvExpr cenv env) args 
 
@@ -1255,7 +1313,7 @@ and FSharpImplementationFileContents(cenv, mimpl) =
         let v = FSharpMemberOrFunctionOrValue(cenv, mkLocalValRef v)
         let gps = v.GenericParameters
         let vslR = List.map (List.map (FSharpExprConvert.ConvVal cenv)) vsl 
-        let env = ExprTranslationEnv.Empty.BindTypars (Seq.zip tps gps |> Seq.toList)
+        let env = ExprTranslationEnv.Empty(cenv.g).BindTypars (Seq.zip tps gps |> Seq.toList)
         let env = env.BindCurriedVals vsl 
         let e = FSharpExprConvert.ConvExprOnDemand cenv env body
         FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v, vslR, e) 
@@ -1277,7 +1335,7 @@ and FSharpImplementationFileContents(cenv, mimpl) =
         | TMDefLet(bind, _m)  ->
             [ yield getBind bind  ]
         | TMDefDo(expr, _m)  ->
-            [ let expr = FSharpExprConvert.ConvExprOnDemand cenv ExprTranslationEnv.Empty expr
+            [ let expr = FSharpExprConvert.ConvExprOnDemand cenv (ExprTranslationEnv.Empty(cenv.g)) expr
               yield FSharpImplementationFileDeclaration.InitAction expr  ]
         | TMDefs mdefs -> 
             [ for mdef in mdefs do yield! getDecls mdef ]
@@ -1303,7 +1361,8 @@ module BasicPatterns =
     let (|NewUnionCase|_|) (e: FSharpExpr) = match e.E with E.NewUnionCase (e, tys, es) -> Some (e, tys, es) | _ -> None
     let (|NewTuple|_|) (e: FSharpExpr) = match e.E with E.NewTuple (ty, es) -> Some (ty, es) | _ -> None
     let (|TupleGet|_|) (e: FSharpExpr) = match e.E with E.TupleGet (ty, n, es) -> Some (ty, n, es) | _ -> None
-    let (|Call|_|) (e: FSharpExpr) = match e.E with E.Call (a, b, c, d, e) -> Some (a, b, c, d, e) | _ -> None
+    let (|Call|_|) (e: FSharpExpr) = match e.E with E.Call (a, b, c, d, _e, f) -> Some (a, b, c, d, f) | _ -> None
+    let (|CallWithWitnesses|_|) (e: FSharpExpr) = match e.E with E.Call (a, b, c, d, e, f) -> Some (a, b, c, d, e, f) | _ -> None
     let (|NewObject|_|) (e: FSharpExpr) = match e.E with E.NewObject (a, b, c) -> Some (a, b, c) | _ -> None
     let (|FSharpFieldGet|_|) (e: FSharpExpr) = match e.E with E.FSharpFieldGet (a, b, c) -> Some (a, b, c) | _ -> None
     let (|AnonRecordGet|_|) (e: FSharpExpr) = match e.E with E.AnonRecordGet (a, b, c) -> Some (a, b, c) | _ -> None
@@ -1335,4 +1394,5 @@ module BasicPatterns =
     let (|DecisionTreeSuccess|_|) (e: FSharpExpr) = match e.E with E.DecisionTreeSuccess (a, b) -> Some (a, b) | _ -> None
     let (|UnionCaseSet|_|) (e: FSharpExpr) = match e.E with E.UnionCaseSet (a, b, c, d, e) -> Some (a, b, c, d, e) | _ -> None
     let (|TraitCall|_|) (e: FSharpExpr) = match e.E with E.TraitCall (a, b, c, d, e, f) -> Some (a, b, c, d, e, f) | _ -> None
+    let (|WitnessArg|_|) (e: FSharpExpr) = match e.E with E.WitnessArg n -> Some n | _ -> None
 

src/fsharp/symbols/Exprs.fsi

@@ -1,6 +1,6 @@
 // Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
 
-namespace FSharp.Compiler.SourceCodeServices
+namespace rec FSharp.Compiler.SourceCodeServices
 
 open FSharp.Compiler.CompilerImports
 open FSharp.Compiler.Range
@@ -17,7 +17,7 @@ type public FSharpAssemblyContents =
     member ImplementationFiles:  FSharpImplementationFileContents list
 
 /// Represents the definitional contents of a single file or fragment in an assembly, as seen by the F# language
-and [<Class>] public FSharpImplementationFileContents = 
+type public FSharpImplementationFileContents = 
     internal new : cenv: SymbolEnv * mimpl: TypedImplFile -> FSharpImplementationFileContents
 
     /// The qualified name acts to fully-qualify module specifications and implementations
@@ -52,7 +52,8 @@ and public FSharpImplementationFileDeclaration =
 ///
 /// Pattern matching is reduced to decision trees and conditional tests. Some other
 /// constructs may be represented in reduced form.
-and [<Sealed>] public FSharpExpr =
+[<Sealed>] 
+type public FSharpExpr =
     /// The range of the expression
     member Range : range
 
@@ -108,6 +109,9 @@ module public BasicPatterns =
     /// arguments are collapsed to a single collection of arguments, as done in the compiled version of these.
     val (|Call|_|) : FSharpExpr -> (FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list) option 
 
+    /// Like Call but also indicates witness arguments
+    val (|CallWithWitnesses|_|) : FSharpExpr -> (FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list * FSharpExpr list) option 
+
     /// Matches expressions which are calls to object constructors 
     val (|NewObject|_|) : FSharpExpr -> (FSharpMemberOrFunctionOrValue * FSharpType list * FSharpExpr list) option 
 
@@ -218,3 +222,5 @@ module public BasicPatterns =
     /// Matches expressions for an unresolved call to a trait 
     val (|TraitCall|_|) : FSharpExpr -> (FSharpType list * string * MemberFlags * FSharpType list * FSharpType list * FSharpExpr list) option 
 
+    /// Indicates a witness argument index from the witness arguments supplied to the enclosing method
+    val (|WitnessArg|_|) : FSharpExpr -> int option