Skip to content

Commit 8d20904

Browse files
majochamajocha
committed
wip
1 parent 23dbf1e commit 8d20904

File tree

3 files changed

+78
-176
lines changed

3 files changed

+78
-176
lines changed

‎src/Compiler/Checking/TypeRelations.fs‎

Lines changed: 5 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -25,28 +25,11 @@ type CanCoerce =
2525
| CanCoerce
2626
| NoCoerce
2727

28-
[<Struct; NoComparison; CustomEquality>]
28+
[<NoComparison>]
2929
type TTypeCacheKey =
30-
31-
val ty1: AccumulateTypes.TypeToken
32-
val ty2: AccumulateTypes.TypeToken
33-
val canCoerce: CanCoerce
34-
35-
new (ty1, ty2, canCoerce) =
36-
{ ty1 = AccumulateTypes.accumulateTType ty1; ty2 = AccumulateTypes.accumulateTType ty2; canCoerce = canCoerce }
37-
38-
interface System.IEquatable<TTypeCacheKey> with
39-
member this.Equals other =
40-
if this.canCoerce <> other.canCoerce then
41-
false
42-
else this.ty1 = other.ty1 && this.ty2 = other.ty2
43-
44-
override this.Equals(other:objnull) =
45-
match other with
46-
| :? TTypeCacheKey as p -> (this :> System.IEquatable<TTypeCacheKey>).Equals p
47-
| _ -> false
48-
49-
override this.GetHashCode () : int = hash this.ty1 ^^^ hash this.ty2 ^^^ hash this.canCoerce
30+
| TTypeCacheKey of TypeStructural.TypeStructure * TypeStructural.TypeStructure * CanCoerce
31+
static member Create(ty1, ty2, canCoerce) =
32+
TTypeCacheKey(TypeStructural.getTypeStructure ty1, TypeStructural.getTypeStructure ty2, canCoerce)
5033

5134
let getTypeSubsumptionCache =
5235
let factory (g: TcGlobals) =
@@ -174,7 +157,7 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1:
174157
List.exists (TypeFeasiblySubsumesType (ndeep + 1) g amap m ty1 NoCoerce) interfaces
175158

176159
if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
177-
let key = TTypeCacheKey(ty1, ty2, canCoerce)
160+
let key = TTypeCacheKey.Create(ty1, ty2, canCoerce)
178161
(getTypeSubsumptionCache g).GetOrAdd(key, fun _ -> checkSubsumes ty1 ty2)
179162
else
180163
checkSubsumes ty1 ty2

‎src/Compiler/Checking/TypeRelations.fsi‎

Lines changed: 0 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -14,19 +14,6 @@ type CanCoerce =
1414
| CanCoerce
1515
| NoCoerce
1616

17-
//[<Struct; NoComparison; CustomEquality>]
18-
//type TTypeCacheKey =
19-
// interface System.IEquatable<TTypeCacheKey>
20-
// private new: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
21-
22-
// static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
23-
24-
// val ty1: TType
25-
// val ty2: TType
26-
// val canCoerce: CanCoerce
27-
28-
// override GetHashCode: unit -> int
29-
3017
/// Implements a :> b without coercion based on finalized (no type variable) types
3118
val TypeDefinitelySubsumesTypeNoCoercion:
3219
ndeep: int -> g: TcGlobals -> amap: ImportMap -> m: range -> ty1: TType -> ty2: TType -> bool

‎src/Compiler/Utilities/TypeHashing.fs‎

Lines changed: 73 additions & 141 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ open FSharp.Compiler.Text
88
open FSharp.Compiler.TypedTree
99
open FSharp.Compiler.TypedTreeBasics
1010
open FSharp.Compiler.TypedTreeOps
11+
open System.Collections.Immutable
1112

1213
type ObserverVisibility =
1314
| PublicOnly
@@ -357,165 +358,96 @@ module HashTastMemberOrVals =
357358
hashNonMemberVal (g, obs) (tps, vref.Deref, tau, cxs)
358359
| Some _ -> hashMember (g, obs) emptyTyparInst vref.Deref
359360

360-
/// Practical TType comparer strictly for the use with cache keys.
361-
module HashStamps =
362-
let rec typeInstStampsEqual (tys1: TypeInst) (tys2: TypeInst) =
363-
tys1.Length = tys2.Length && (tys1, tys2) ||> Seq.forall2 stampEquals
364-
365-
and inline typarStampEquals (t1: Typar) (t2: Typar) = t1.Stamp = t2.Stamp
366-
367-
and typarsStampsEqual (tps1: Typars) (tps2: Typars) =
368-
tps1.Length = tps2.Length && (tps1, tps2) ||> Seq.forall2 typarStampEquals
369-
370-
and measureStampEquals (m1: Measure) (m2: Measure) =
371-
match m1, m2 with
372-
| Measure.Var(mv1), Measure.Var(mv2) -> mv1.Stamp = mv2.Stamp
373-
| Measure.Const(t1, _), Measure.Const(t2, _) -> t1.Stamp = t2.Stamp
374-
| Measure.Prod(m1, m2, _), Measure.Prod(m3, m4, _) -> measureStampEquals m1 m3 && measureStampEquals m2 m4
375-
| Measure.Inv m1, Measure.Inv m2 -> measureStampEquals m1 m2
376-
| Measure.One _, Measure.One _ -> true
377-
| Measure.RationalPower(m1, r1), Measure.RationalPower(m2, r2) -> r1 = r2 && measureStampEquals m1 m2
378-
| _ -> false
379-
380-
and nullnessEquals (n1: Nullness) (n2: Nullness) =
381-
match n1, n2 with
382-
| Nullness.Known k1, Nullness.Known k2 -> k1 = k2
383-
| Nullness.Variable _, Nullness.Variable _ -> true
384-
| _ -> false
385-
386-
and stampEquals ty1 ty2 =
387-
match ty1, ty2 with
388-
| TType_ucase(u, tys1), TType_ucase(v, tys2) -> u.CaseName = v.CaseName && typeInstStampsEqual tys1 tys2
389-
| TType_app(tcref1, tinst1, n1), TType_app(tcref2, tinst2, n2) ->
390-
tcref1.Stamp = tcref2.Stamp
391-
&& nullnessEquals n1 n2
392-
&& typeInstStampsEqual tinst1 tinst2
393-
| TType_anon(info1, tys1), TType_anon(info2, tys2) -> info1.Stamp = info2.Stamp && typeInstStampsEqual tys1 tys2
394-
| TType_tuple(c1, tys1), TType_tuple(c2, tys2) -> c1 = c2 && typeInstStampsEqual tys1 tys2
395-
| TType_forall(tps1, tau1), TType_forall(tps2, tau2) -> stampEquals tau1 tau2 && typarsStampsEqual tps1 tps2
396-
| TType_var(r1, n1), TType_var(r2, n2) -> r1.Stamp = r2.Stamp && nullnessEquals n1 n2
397-
| TType_measure m1, TType_measure m2 -> measureStampEquals m1 m2
398-
| _ -> false
399-
400-
let inline hashStamp (x: Stamp) : Hash = uint x * 2654435761u |> int
401-
402-
// The idea is to keep the illusion of immutability of TType.
403-
// This hash must be stable during compilation, otherwise we won't be able to find keys or evict from the cache.
404-
let rec hashTType ty : Hash =
405-
match ty with
406-
| TType_ucase(u, tinst) -> tinst |> hashListOrderMatters (hashTType) |> pipeToHash (hash u.CaseName)
407-
| TType_app(tcref, tinst, Nullness.Known n) ->
408-
tinst
409-
|> hashListOrderMatters (hashTType)
410-
|> pipeToHash (hashStamp tcref.Stamp)
411-
|> pipeToHash (hash n)
412-
| TType_app(tcref, tinst, Nullness.Variable _) -> tinst |> hashListOrderMatters (hashTType) |> pipeToHash (hashStamp tcref.Stamp)
413-
| TType_anon(info, tys) -> tys |> hashListOrderMatters (hashTType) |> pipeToHash (hashStamp info.Stamp)
414-
| TType_tuple(c, tys) -> tys |> hashListOrderMatters (hashTType) |> pipeToHash (hash c)
415-
| TType_forall(tps, tau) ->
416-
tps
417-
|> Seq.map _.Stamp
418-
|> hashListOrderMatters (hashStamp)
419-
|> pipeToHash (hashTType tau)
420-
| TType_fun(d, r, Nullness.Known n) -> hashTType d |> pipeToHash (hashTType r) |> pipeToHash (hash n)
421-
| TType_fun(d, r, Nullness.Variable _) -> hashTType d |> pipeToHash (hashTType r)
422-
| TType_var(r, Nullness.Known n) -> hashStamp r.Stamp |> pipeToHash (hash n)
423-
| TType_var(r, Nullness.Variable _) -> hashStamp r.Stamp
424-
| TType_measure _ -> 0
425-
426-
/// Lossless accumulation of TType structure (parallel to HashStamps.hashTType but retaining full shape tokens)
427-
module AccumulateTypes =
361+
/// Lossless accumulation of TType structure
362+
module TypeStructural =
363+
// Helper struct whose instances are never equal (even to themselves).
364+
[<Struct; CustomEquality; NoComparison>]
365+
type NeverEqual =
366+
struct
367+
interface System.IEquatable<NeverEqual> with
368+
member _.Equals _ = false
369+
370+
override _.Equals(_) = false
371+
override _.GetHashCode() = 0
372+
end
373+
374+
[<Struct; NoComparison>]
428375
type NullnessToken =
429-
| Known of NullnessInfo
430-
| Variable
376+
| Known of info: NullnessInfo
377+
| Variable of never: NeverEqual
431378
| Absent
432379

433380
/// Convert compiler Nullness info to token form
434381
let inline toNullnessToken (n: Nullness) =
435382
match n with
436383
| Nullness.Known k -> NullnessToken.Known k
437-
| Nullness.Variable _ -> NullnessToken.Variable
384+
| Nullness.Variable _ -> NullnessToken.Variable(NeverEqual())
438385

439386
/// Tokens capturing a lossless, structural representation of TType needed for deterministic keys.
387+
[<Struct; NoComparison>]
440388
type TypeToken =
441-
| UCase of string * TypeToken list
442-
| App of Stamp * NullnessToken * TypeToken list
443-
| Anon of Stamp * TypeToken list
444-
| Tuple of bool * TypeToken list
445-
| Forall of Stamp list * TypeToken
446-
| Fun of TypeToken * TypeToken * NullnessToken
447-
| Var of Stamp * NullnessToken
448-
| Measure of MeasureToken
449-
and MeasureToken =
450-
| MVar of Stamp
451-
| MConst of Stamp
452-
| MProd of MeasureToken * MeasureToken
453-
| MInv of MeasureToken
454-
| MOne
455-
| MRationalPower of MeasureToken * Rational
389+
| Stamp of stamp: Stamp
390+
| UCase of name: string
391+
| Nullness of nullness: NullnessToken
392+
| TupInfo of b: bool
393+
| MeasureOne
394+
| MeasureRational of rational: Rational
395+
396+
type TypeStructure = TypeToken[]
456397

457398
/// Accumulate Measure to MeasureToken
458-
let rec private accumulateMeasure m =
399+
let rec private accumulateMeasure m acc =
459400
match m with
460-
| Measure.Var mv -> MVar mv.Stamp
461-
| Measure.Const(tcref, _) -> MConst tcref.Stamp
462-
| Measure.Prod(m1, m2, _) -> MProd(accumulateMeasure m1, accumulateMeasure m2)
463-
| Measure.Inv m1 -> MInv (accumulateMeasure m1)
464-
| Measure.One _ -> MOne
465-
| Measure.RationalPower(m1, r) -> MRationalPower(accumulateMeasure m1, r)
466-
467-
/// Accumulate a TType into a lossless token tree. Uses stamps for identity where appropriate (matching hashTType logic).
468-
let rec accumulateTType (ty: TType) : TypeToken =
401+
| Measure.Var mv -> acc (Stamp mv.Stamp)
402+
| Measure.Const(tcref, _) -> acc (Stamp tcref.Stamp)
403+
| Measure.Prod(m1, m2, _) ->
404+
accumulateMeasure m1 acc
405+
accumulateMeasure m2 acc
406+
| Measure.Inv m1 -> accumulateMeasure m1 acc
407+
| Measure.One _ -> acc MeasureOne
408+
| Measure.RationalPower(m1, r) ->
409+
accumulateMeasure m1 acc
410+
acc (MeasureRational r)
411+
412+
/// Accumulate a TType into a lossless token list. Uses stamps for identity where appropriate (matching hashTType logic).
413+
let rec private accumulateTType (ty: TType) acc =
469414
match ty with
470415
| TType_ucase(u, tinst) ->
471-
let args = tinst |> List.map accumulateTType
472-
UCase(u.CaseName, args)
416+
acc (UCase u.CaseName)
417+
418+
for arg in tinst do
419+
accumulateTType arg acc
473420
| TType_app(tcref, tinst, n) ->
474-
let args = tinst |> List.map accumulateTType
475-
App(tcref.Stamp, toNullnessToken n, args)
421+
acc (Stamp tcref.Stamp)
422+
acc (Nullness(toNullnessToken n))
423+
424+
for arg in tinst do
425+
accumulateTType arg acc
476426
| TType_anon(info, tys) ->
477-
let args = tys |> List.map accumulateTType
478-
Anon(info.Stamp, args)
427+
acc (Stamp info.Stamp)
428+
429+
for arg in tys do
430+
accumulateTType arg acc
479431
| TType_tuple(tupInfo, tys) ->
480-
let elems = tys |> List.map accumulateTType
481-
let isStruct = evalTupInfoIsStruct tupInfo
482-
Tuple(isStruct, elems)
432+
acc (TupInfo(evalTupInfoIsStruct tupInfo))
433+
434+
for arg in tys do
435+
accumulateTType arg acc
483436
| TType_forall(tps, tau) ->
484-
let stamps = tps |> List.map (fun tp -> tp.Stamp)
485-
let body = accumulateTType tau
486-
Forall(stamps, body)
437+
for tp in tps do
438+
acc (Stamp tp.Stamp)
439+
440+
accumulateTType tau acc
487441
| TType_fun(d, r, n) ->
488-
Fun(accumulateTType d, accumulateTType r, toNullnessToken n)
442+
accumulateTType d acc
443+
accumulateTType r acc
444+
acc (Nullness(toNullnessToken n))
489445
| TType_var(r, n) ->
490-
Var(r.Stamp, toNullnessToken n)
491-
| TType_measure m -> Measure (accumulateMeasure m)
492-
493-
// /// Flatten accumulated token tree to a sequence of simple discriminators and payload (useful for generic hashing/serialization)
494-
//let flatten (root: TypeToken) : obj list =
495-
// let res = System.Collections.Generic.List<obj>()
496-
// let rec loop tt =
497-
// match tt with
498-
// | UCase(name, args) ->
499-
// res.Add "UCASE"; res.Add name; res.Add args.Length; args |> List.iter loop
500-
// | App(stamp, nTok, args) ->
501-
// res.Add "APP"; res.Add stamp; res.Add (match nTok with | Known k -> box k | Variable -> box "VAR" | Absent -> box null);
502-
// res.Add args.Length; args |> List.iter loop
503-
// | Anon(stamp, args) -> res.Add "ANON"; res.Add stamp; res.Add args.Length; args |> List.iter loop
504-
// | Tuple(isStruct, elems) -> res.Add "TUP"; res.Add isStruct; res.Add elems.Length; elems |> List.iter loop
505-
// | Forall(stamps, body) -> res.Add "FORALL"; res.Add stamps.Length; stamps |> List.iter (fun s -> res.Add s); loop body
506-
// | Fun(d, r, nTok) ->
507-
// res.Add "FUN"; res.Add (match nTok with | Known k -> box k | Variable -> box "VAR" | Absent -> box null); loop d; loop r
508-
// | Var(stamp, nTok) -> res.Add "VAR"; res.Add stamp; res.Add (match nTok with | Known k -> box k | Variable -> box "VAR" | Absent -> box null)
509-
// | Measure m ->
510-
// res.Add "MEASURE"
511-
// let rec loopM mt =
512-
// match mt with
513-
// | MVar s -> res.Add "MVAR"; res.Add s
514-
// | MConst s -> res.Add "MCONST"; res.Add s
515-
// | MProd(a, b) -> res.Add "MPROD"; loopM a; loopM b
516-
// | MInv x -> res.Add "MINV"; loopM x
517-
// | MOne -> res.Add "MONE"
518-
// | MRationalPower(x, r) -> res.Add "MRAT"; res.Add (box r); loopM x
519-
// loopM m
520-
// loop root
521-
// res |> Seq.toList
446+
acc (Stamp r.Stamp)
447+
acc (Nullness(toNullnessToken n))
448+
| TType_measure m -> accumulateMeasure m acc
449+
450+
let getTypeStructure ty =
451+
let tokens = ResizeArray()
452+
accumulateTType ty tokens.Add
453+
tokens.ToArray()

0 commit comments

Comments
 (0)