Skip to content

Commit 23dbf1e

Browse files
majochamajocha
committed
Merge branch 'cache-2' of https://github.com/majocha/fsharp into cache-2
2 parents 3c7d950 + ff33652 commit 23dbf1e

File tree

4 files changed

+120
-30
lines changed

4 files changed

+120
-30
lines changed

‎src/Compiler/Checking/TypeRelations.fs‎

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

28-
[<Struct; NoComparison; CustomEquality; System.Diagnostics.DebuggerDisplay("{ToString()}")>]
28+
[<Struct; NoComparison; CustomEquality>]
2929
type TTypeCacheKey =
3030

31-
val ty1: TType
32-
val ty2: TType
31+
val ty1: AccumulateTypes.TypeToken
32+
val ty2: AccumulateTypes.TypeToken
3333
val canCoerce: CanCoerce
3434

35-
private new (ty1, ty2, canCoerce) =
36-
{ ty1 = ty1; ty2 = ty2; canCoerce = canCoerce }
37-
38-
static member FromStrippedTypes (ty1, ty2, canCoerce) =
39-
TTypeCacheKey(ty1, ty2, canCoerce)
35+
new (ty1, ty2, canCoerce) =
36+
{ ty1 = AccumulateTypes.accumulateTType ty1; ty2 = AccumulateTypes.accumulateTType ty2; canCoerce = canCoerce }
4037

4138
interface System.IEquatable<TTypeCacheKey> with
4239
member this.Equals other =
4340
if this.canCoerce <> other.canCoerce then
4441
false
45-
elif this.ty1 === other.ty1 && this.ty2 === other.ty2 then
46-
true
47-
else
48-
HashStamps.stampEquals this.ty1 other.ty1
49-
&& HashStamps.stampEquals this.ty2 other.ty2
42+
else this.ty1 = other.ty1 && this.ty2 = other.ty2
5043

5144
override this.Equals(other:objnull) =
5245
match other with
5346
| :? TTypeCacheKey as p -> (this :> System.IEquatable<TTypeCacheKey>).Equals p
5447
| _ -> false
5548

56-
override this.GetHashCode () : int =
57-
HashStamps.hashTType this.ty1
58-
|> pipeToHash (HashStamps.hashTType this.ty2)
59-
|> pipeToHash (hash this.canCoerce)
60-
61-
override this.ToString () = $"{this.ty1.DebugText}-{this.ty2.DebugText}"
49+
override this.GetHashCode () : int = hash this.ty1 ^^^ hash this.ty2 ^^^ hash this.canCoerce
6250

6351
let getTypeSubsumptionCache =
6452
let factory (g: TcGlobals) =
@@ -186,8 +174,8 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1:
186174
List.exists (TypeFeasiblySubsumesType (ndeep + 1) g amap m ty1 NoCoerce) interfaces
187175

188176
if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
189-
let key = TTypeCacheKey.FromStrippedTypes (ty1, ty2, canCoerce)
190-
(getTypeSubsumptionCache g).GetOrAdd(key, fun key -> checkSubsumes key.ty1 key.ty2)
177+
let key = TTypeCacheKey(ty1, ty2, canCoerce)
178+
(getTypeSubsumptionCache g).GetOrAdd(key, fun _ -> checkSubsumes ty1 ty2)
191179
else
192180
checkSubsumes ty1 ty2
193181

‎src/Compiler/Checking/TypeRelations.fsi‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -14,18 +14,18 @@ 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
17+
//[<Struct; NoComparison; CustomEquality>]
18+
//type TTypeCacheKey =
19+
// interface System.IEquatable<TTypeCacheKey>
20+
// private new: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
2121

22-
static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
22+
// static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
2323

24-
val ty1: TType
25-
val ty2: TType
26-
val canCoerce: CanCoerce
24+
// val ty1: TType
25+
// val ty2: TType
26+
// val canCoerce: CanCoerce
2727

28-
override GetHashCode: unit -> int
28+
// override GetHashCode: unit -> int
2929

3030
/// Implements a :> b without coercion based on finalized (no type variable) types
3131
val TypeDefinitelySubsumesTypeNoCoercion:

‎src/Compiler/Utilities/TypeHashing.fs‎

Lines changed: 97 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -422,3 +422,100 @@ module HashStamps =
422422
| TType_var(r, Nullness.Known n) -> hashStamp r.Stamp |> pipeToHash (hash n)
423423
| TType_var(r, Nullness.Variable _) -> hashStamp r.Stamp
424424
| TType_measure _ -> 0
425+
426+
/// Lossless accumulation of TType structure (parallel to HashStamps.hashTType but retaining full shape tokens)
427+
module AccumulateTypes =
428+
type NullnessToken =
429+
| Known of NullnessInfo
430+
| Variable
431+
| Absent
432+
433+
/// Convert compiler Nullness info to token form
434+
let inline toNullnessToken (n: Nullness) =
435+
match n with
436+
| Nullness.Known k -> NullnessToken.Known k
437+
| Nullness.Variable _ -> NullnessToken.Variable
438+
439+
/// Tokens capturing a lossless, structural representation of TType needed for deterministic keys.
440+
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
456+
457+
/// Accumulate Measure to MeasureToken
458+
let rec private accumulateMeasure m =
459+
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 =
469+
match ty with
470+
| TType_ucase(u, tinst) ->
471+
let args = tinst |> List.map accumulateTType
472+
UCase(u.CaseName, args)
473+
| TType_app(tcref, tinst, n) ->
474+
let args = tinst |> List.map accumulateTType
475+
App(tcref.Stamp, toNullnessToken n, args)
476+
| TType_anon(info, tys) ->
477+
let args = tys |> List.map accumulateTType
478+
Anon(info.Stamp, args)
479+
| TType_tuple(tupInfo, tys) ->
480+
let elems = tys |> List.map accumulateTType
481+
let isStruct = evalTupInfoIsStruct tupInfo
482+
Tuple(isStruct, elems)
483+
| TType_forall(tps, tau) ->
484+
let stamps = tps |> List.map (fun tp -> tp.Stamp)
485+
let body = accumulateTType tau
486+
Forall(stamps, body)
487+
| TType_fun(d, r, n) ->
488+
Fun(accumulateTType d, accumulateTType r, toNullnessToken n)
489+
| 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

‎vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,9 @@
1717
</PropertyGroup>
1818

1919
<ItemGroup>
20+
<Compile Include="$(FSharpTestsRoot)\FSharp.Test.Utilities\XunitSetup.fs">
21+
<Link>XunitSetup.fs</Link>
22+
</Compile>
2023
<Compile Include="$(FSharpSourcesRoot)\Compiler\Utilities\NullnessShims.fs" />
2124
<Compile Include="AssemblyResolver.fs" />
2225
<Compile Include="$(FSharpSourcesRoot)\Compiler\Utilities\InternalCollections.fsi">
@@ -73,6 +76,8 @@
7376
</ItemGroup>
7477
<ItemGroup>
7578
<ProjectReference Include="$(FSharpSourcesRoot)\fsc\fscAnyCpuProject\fscAnyCpu.fsproj" />
79+
<ProjectReference Include="..\..\..\tests\FSharp.Test.Utilities\FSharp.Test.Utilities.fsproj" />
80+
<ProjectReference Include="$(FSharpSourcesRoot)\fsc\fscProject\fsc.fsproj" />
7681
<ProjectReference Include="$(FSharpSourcesRoot)\FSharp.Build\FSharp.Build.fsproj" />
7782
<ProjectReference Include="$(FSharpSourcesRoot)\Compiler\FSharp.Compiler.Service.fsproj" />
7883
<ProjectReference Include="..\Salsa\VisualFSharp.Salsa.fsproj" />

0 commit comments

Comments
 (0)