forked from dotnet/fsharp
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathTypeRelations.fs
More file actions
300 lines (262 loc) · 13.8 KB
/
Copy pathTypeRelations.fs
File metadata and controls
300 lines (262 loc) · 13.8 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information.
/// Primary relations on types and signatures, with the exception of
/// constraint solving and method overload resolution.
module internal Microsoft.FSharp.Compiler.TypeRelations
open Internal.Utilities
open System.Text
open Microsoft.FSharp.Compiler
open Microsoft.FSharp.Compiler.AbstractIL
open Microsoft.FSharp.Compiler.AbstractIL.IL
open Microsoft.FSharp.Compiler.AbstractIL.Internal
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
open Microsoft.FSharp.Compiler.Range
open Microsoft.FSharp.Compiler.Ast
open Microsoft.FSharp.Compiler.ErrorLogger
open Microsoft.FSharp.Compiler.Tast
open Microsoft.FSharp.Compiler.Tastops
open Microsoft.FSharp.Compiler.Tastops.DebugPrint
open Microsoft.FSharp.Compiler.TcGlobals
open Microsoft.FSharp.Compiler.AbstractIL.IL
open Microsoft.FSharp.Compiler.Lib
open Microsoft.FSharp.Compiler.Infos
open Microsoft.FSharp.Compiler.PrettyNaming
open Microsoft.FSharp.Compiler.AccessibilityLogic
open Microsoft.FSharp.Compiler.NameResolution
//-------------------------------------------------------------------------
// a :> b without coercion based on finalized (no type variable) types
//-------------------------------------------------------------------------
// QUERY: This relation is approximate and not part of the language specification.
//
// Some appropriate uses:
// patcompile.fs: IsDiscrimSubsumedBy (approximate warning for redundancy of 'isinst' patterns)
// tc.fs: TcRuntimeTypeTest (approximate warning for redundant runtime type tests)
// tc.fs: TcExnDefnCore (error for bad exception abbreviation)
// ilxgen.fs: GenCoerce (omit unnecessary castclass or isinst instruction)
//
let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 =
if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeDefinitelySubsumesTypeNoCoercion), ty1 = "^(DebugPrint.showType ty1),m))
if ty1 === ty2 then true
// QUERY : quadratic
elif typeEquiv g ty1 ty2 then true
else
let ty1 = stripTyEqns g ty1
let ty2 = stripTyEqns g ty2
match ty1,ty2 with
| TType_app (tc1,l1) ,TType_app (tc2,l2) when tyconRefEq g tc1 tc2 ->
List.lengthsEqAndForall2 (typeEquiv g) l1 l2
| TType_ucase (tc1,l1) ,TType_ucase (tc2,l2) when g.unionCaseRefEq tc1 tc2 ->
List.lengthsEqAndForall2 (typeEquiv g) l1 l2
| TType_tuple (tupInfo1,l1) ,TType_tuple (tupInfo2,l2) ->
evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
List.lengthsEqAndForall2 (typeEquiv g) l1 l2
| TType_fun (d1,r1) ,TType_fun (d2,r2) ->
typeEquiv g d1 d2 && typeEquiv g r1 r2
| TType_measure measure1, TType_measure measure2 ->
measureEquiv g measure1 measure2
| _ ->
(typeEquiv g ty1 g.obj_ty && isRefTy g ty2) || (* F# reference types are subtypes of type 'obj' *)
(isAppTy g ty2 &&
isRefTy g ty2 &&
((match GetSuperTypeOfType g amap m ty2 with
| None -> false
| Some ty -> TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1 ty) ||
(isInterfaceTy g ty1 &&
ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m
|> List.exists (TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1))))
type CanCoerce = CanCoerce | NoCoerce
/// The feasible equivalence relation. Part of the language spec.
let rec TypesFeasiblyEquiv ndeep g amap m ty1 ty2 =
if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = "^(DebugPrint.showType ty1),m));
let ty1 = stripTyEqns g ty1
let ty2 = stripTyEqns g ty2
match ty1,ty2 with
// QUERY: should these be false for non-equal rigid typars? warn-if-not-rigid typars?
| TType_var _ , _
| _, TType_var _ -> true
| TType_app (tc1,l1) ,TType_app (tc2,l2) when tyconRefEq g tc1 tc2 ->
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
| TType_tuple (tupInfo1, l1) ,TType_tuple (tupInfo2, l2) ->
evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
| TType_fun (d1,r1) ,TType_fun (d2,r2) ->
(TypesFeasiblyEquiv ndeep g amap m) d1 d2 && (TypesFeasiblyEquiv ndeep g amap m) r1 r2
| TType_measure _, TType_measure _ ->
true
| _ ->
false
/// The feasible coercion relation. Part of the language spec.
let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =
if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = "^(DebugPrint.showType ty1),m))
let ty1 = stripTyEqns g ty1
let ty2 = stripTyEqns g ty2
match ty1,ty2 with
// QUERY: should these be false for non-equal rigid typars? warn-if-not-rigid typars?
| TType_var _ , _ | _, TType_var _ -> true
| TType_app (tc1,l1) ,TType_app (tc2,l2) when tyconRefEq g tc1 tc2 ->
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
| TType_tuple (tupInfo1,l1) ,TType_tuple (tupInfo2,l2) ->
evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
| TType_fun (d1,r1) ,TType_fun (d2,r2) ->
(TypesFeasiblyEquiv ndeep g amap m) d1 d2 && (TypesFeasiblyEquiv ndeep g amap m) r1 r2
| TType_measure _, TType_measure _ ->
true
| _ ->
// F# reference types are subtypes of type 'obj'
(isObjTy g ty1 && (canCoerce = CanCoerce || isRefTy g ty2))
||
(isAppTy g ty2 &&
(canCoerce = CanCoerce || isRefTy g ty2) &&
begin match GetSuperTypeOfType g amap m ty2 with
| None -> false
| Some ty -> TypeFeasiblySubsumesType (ndeep+1) g amap m ty1 NoCoerce ty
end ||
ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m
|> List.exists (TypeFeasiblySubsumesType (ndeep+1) g amap m ty1 NoCoerce))
/// Choose solutions for Expr.TyChoose type "hidden" variables introduced
/// by letrec nodes. Also used by the pattern match compiler to choose type
/// variables when compiling patterns at generalized bindings.
/// e.g. let ([],x) = ([],[])
/// Here x gets a generalized type "list<'T>".
let ChooseTyparSolutionAndRange g amap (tp:Typar) =
let m = tp.Range
let max,m =
let initial =
match tp.Kind with
| TyparKind.Type -> g.obj_ty
| TyparKind.Measure -> TType_measure Measure.One
// Loop through the constraints computing the lub
((initial,m), tp.Constraints) ||> List.fold (fun (maxSoFar,_) tpc ->
let join m x =
if TypeFeasiblySubsumesType 0 g amap m x CanCoerce maxSoFar then maxSoFar
elif TypeFeasiblySubsumesType 0 g amap m maxSoFar CanCoerce x then x
else errorR(Error(FSComp.SR.typrelCannotResolveImplicitGenericInstantiation((DebugPrint.showType x), (DebugPrint.showType maxSoFar)),m)); maxSoFar
// Don't continue if an error occurred and we set the value eagerly
if tp.IsSolved then maxSoFar,m else
match tpc with
| TyparConstraint.CoercesTo(x,m) ->
join m x,m
| TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m))
maxSoFar,m
| TyparConstraint.SimpleChoice(_,m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(),m))
maxSoFar,m
| TyparConstraint.SupportsNull m ->
maxSoFar,m
| TyparConstraint.SupportsComparison m ->
join m g.mk_IComparable_ty,m
| TyparConstraint.SupportsEquality m ->
maxSoFar,m
| TyparConstraint.IsEnum(_,m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInEnum(),m))
maxSoFar,m
| TyparConstraint.IsDelegate(_,_,m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInDelegate(),m))
maxSoFar,m
| TyparConstraint.IsNonNullableStruct m ->
join m g.int_ty,m
| TyparConstraint.IsUnmanaged m ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInUnmanaged(),m))
maxSoFar,m
| TyparConstraint.RequiresDefaultConstructor m ->
maxSoFar,m
| TyparConstraint.IsReferenceType m ->
maxSoFar,m
| TyparConstraint.DefaultsTo(_priority,_ty,m) ->
maxSoFar,m)
max,m
let ChooseTyparSolution g amap tp =
let ty,_m = ChooseTyparSolutionAndRange g amap tp
if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure Measure.One) then
warning(Error(FSComp.SR.csCodeLessGeneric(),tp.Range))
ty
// Solutions can, in theory, refer to each other
// For example
// 'a = Expr<'b>
// 'b = int
// In this case the solutions are
// 'a = Expr<int>
// 'b = int
// We ground out the solutions by repeatedly instantiating
let IterativelySubstituteTyparSolutions g tps solutions =
let tpenv = mkTyparInst tps solutions
let rec loop n curr =
let curr' = curr |> instTypes tpenv
// We cut out at n > 40 just in case this loops. It shouldn't, since there should be no cycles in the
// solution equations, and we've only ever seen one example where even n = 2 was required.
// Perhaps it's possible in error recovery some strange situations could occur where cycles
// arise, so it's better to be on the safe side.
//
// We don't give an error if we hit the limit since it's feasible that the solutions of unknowns
// is not actually relevant to the rest of type checking or compilation.
if n > 40 || List.forall2 (typeEquiv g) curr curr' then
curr
else
loop (n+1) curr'
loop 0 solutions
let ChooseTyparSolutionsForFreeChoiceTypars g amap e =
match e with
| Expr.TyChoose(tps,e1,_m) ->
/// Only make choices for variables that are actually used in the expression
let ftvs = (freeInExpr CollectTyparsNoCaching e1).FreeTyvars.FreeTypars
let tps = tps |> List.filter (Zset.memberOf ftvs)
let solutions = tps |> List.map (ChooseTyparSolution g amap) |> IterativelySubstituteTyparSolutions g tps
let tpenv = mkTyparInst tps solutions
instExpr g tpenv e1
| _ -> e
/// Break apart lambdas. Needs ChooseTyparSolutionsForFreeChoiceTypars because it's used in
/// PostTypeCheckSemanticChecks before we've eliminated these nodes.
let tryDestTopLambda g amap (ValReprInfo (tpNames,_,_) as tvd) (e,ty) =
let rec stripLambdaUpto n (e,ty) =
match e with
| Expr.Lambda (_,None,None,v,b,_,retTy) when n > 0 ->
let (vs',b',retTy') = stripLambdaUpto (n-1) (b,retTy)
(v :: vs', b', retTy')
| _ ->
([],e,ty)
let rec startStripLambdaUpto n (e,ty) =
match e with
| Expr.Lambda (_,ctorThisValOpt,baseValOpt,v,b,_,retTy) when n > 0 ->
let (vs',b',retTy') = stripLambdaUpto (n-1) (b,retTy)
(ctorThisValOpt,baseValOpt, (v :: vs'), b', retTy')
| Expr.TyChoose (_tps,_b,_) ->
startStripLambdaUpto n (ChooseTyparSolutionsForFreeChoiceTypars g amap e, ty)
| _ ->
(None,None,[],e,ty)
let n = tvd.NumCurriedArgs
let tps,taue,tauty =
match e with
| Expr.TyLambda (_,tps,b,_,retTy) when not (List.isEmpty tpNames) -> tps,b,retTy
| _ -> [],e,ty
let ctorThisValOpt,baseValOpt,vsl,body,retTy = startStripLambdaUpto n (taue,tauty)
if vsl.Length <> n then
None
else
Some (tps,ctorThisValOpt,baseValOpt,vsl,body,retTy)
let destTopLambda g amap topValInfo (e,ty) =
match tryDestTopLambda g amap topValInfo (e,ty) with
| None -> error(Error(FSComp.SR.typrelInvalidValue(), e.Range))
| Some res -> res
let IteratedAdjustArityOfLambdaBody g arities vsl body =
(arities, vsl, ([],body)) |||> List.foldBack2 (fun arities vs (allvs,body) ->
let vs,body = AdjustArityOfLambdaBody g arities vs body
vs :: allvs, body)
/// Do AdjustArityOfLambdaBody for a series of
/// iterated lambdas, producing one method.
/// The required iterated function arity (List.length topValInfo) must be identical
/// to the iterated function arity of the input lambda (List.length vsl)
let IteratedAdjustArityOfLambda g amap topValInfo e =
let tps,ctorThisValOpt,baseValOpt,vsl,body,bodyty = destTopLambda g amap topValInfo (e, tyOfExpr g e)
let arities = topValInfo.AritiesOfArgs
if arities.Length <> vsl.Length then
errorR(InternalError(sprintf "IteratedAdjustArityOfLambda, List.length arities = %d, List.length vsl = %d" (List.length arities) (List.length vsl), body.Range))
let vsl,body = IteratedAdjustArityOfLambdaBody g arities vsl body
tps,ctorThisValOpt,baseValOpt,vsl,body,bodyty
/// "Single Feasible Type" inference
/// Look for the unique supertype of ty2 for which ty2 :> ty1 might feasibly hold
let FindUniqueFeasibleSupertype g amap m ty1 ty2 =
if not (isAppTy g ty2) then None else
let supertypes = Option.toList (GetSuperTypeOfType g amap m ty2) @ (GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m ty2)
supertypes |> List.tryFind (TypeFeasiblySubsumesType 0 g amap m ty1 NoCoerce)