Skip to content

Commit

Permalink
temp
Browse files Browse the repository at this point in the history
  • Loading branch information
@KevinRansom
KevinRansom committed Oct 20, 2024
1 parent 99f44e1 commit a7eeda8
Showing 1 changed file with 62 additions and 44 deletions.
106 changes: 62 additions & 44 deletions src/Compiler/TypedTree/TypedTreeOps.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -219,8 +219,11 @@ let rec remapTypeAux (tyenv: Remap) (ty: TType) =
if domainTy === domainTyR && rangeTy === retTyR then ty else
TType_fun (domainTyR, retTyR, flags)

| TType_forall (tps, ty) ->
let tpsR, tyenv = copyAndRemapAndBindTypars tyenv tps
| TType_forall (tps, ty) ->
let tpsR, tyenv =
match tyenv.realsig with
| false -> copyAndRemapAndBindTypars tyenv tps
| true -> tps, tyenv
TType_forall (tpsR, remapTypeAux tyenv ty)

| TType_measure unt ->
Expand Down Expand Up @@ -328,16 +331,12 @@ and copyAndRemapAndBindTyparsFull remapAttrib tyenv tps =
match tps with
| [] -> tps, tyenv
| _ ->
match tyenv.realsig with
| true ->
tps, tyenv
| false ->
let tpsR = copyTypars false tps
let tyenv = { tyenv with tpinst = bindTypars tps (generalizeTypars tpsR) tyenv.tpinst }
(tps, tpsR) ||> List.iter2 (fun tporig tp ->
tp.SetConstraints (remapTyparConstraintsAux tyenv tporig.Constraints)
tp.SetAttribs (tporig.Attribs |> remapAttrib))
tpsR, tyenv
let tpsR = copyTypars false tps
let tyenv = { tyenv with tpinst = bindTypars tps (generalizeTypars tpsR) tyenv.tpinst }
(tps, tpsR) ||> List.iter2 (fun tporig tp ->
tp.SetConstraints (remapTyparConstraintsAux tyenv tporig.Constraints)
tp.SetAttribs (tporig.Attribs |> remapAttrib))
tpsR, tyenv

// copies bound typars, extends tpinst
and copyAndRemapAndBindTypars tyenv tps =
Expand Down Expand Up @@ -389,13 +388,16 @@ let remapTypes tyenv x =
/// We currently break the recursion by passing in remapAttribImpl as a function parameter.
/// Use this one for any type that may be a forall type where the type variables may contain attributes
let remapTypeFull remapAttrib tyenv ty =
if isRemapEmpty tyenv then ty else
match stripTyparEqns ty with
| TType_forall(tps, tau) ->
let tpsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv tps
TType_forall(tpsR, remapType tyenvinner tau)
| _ ->
remapType tyenv ty
if isRemapEmpty tyenv then ty
else
match tyenv.realsig, stripTyparEqns ty with
| false, TType_forall(tps, tau) ->
let tpsR, tyenvinner =
match tyenv.realsig with
| false -> copyAndRemapAndBindTyparsFull remapAttrib tyenv tps
| true -> tps, tyenv
TType_forall(tpsR, remapType tyenvinner tau)
| _-> remapType tyenv ty

let remapParam tyenv (TSlotParam(nm, ty, fl1, fl2, fl3, attribs) as x) =
if isRemapEmpty tyenv then x else
Expand All @@ -404,7 +406,11 @@ let remapParam tyenv (TSlotParam(nm, ty, fl1, fl2, fl3, attribs) as x) =
let remapSlotSig remapAttrib tyenv (TSlotSig(nm, ty, ctps, methTypars, paraml, retTy) as x) =
if isRemapEmpty tyenv then x else
let tyR = remapTypeAux tyenv ty
let ctpsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv ctps
let ctpsR, tyenvinner =
match tyenv.realsig with
| false -> copyAndRemapAndBindTyparsFull remapAttrib tyenv ctps
| true -> ctps, tyenv

let methTyparsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenvinner methTypars
TSlotSig(nm, tyR, ctpsR, methTyparsR, List.mapSquared (remapParam tyenvinner) paraml, Option.map (remapTypeAux tyenvinner) retTy)

Expand Down Expand Up @@ -5869,10 +5875,14 @@ let remapAttribKind tmenv k =
| ILAttrib _ as x -> x
| FSAttrib vref -> FSAttrib(remapValRef tmenv vref)

let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps =
let tps', tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tmenv tps
let tmenvinner = tyenvinner
tps', tmenvinner
let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps =
match tmenv.realsig with
| false ->
let tps', tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tmenv tps
let tmenvinner = tyenvinner
tps', tmenvinner
| true ->
tps, tmenv

type RemapContext =
{ g: TcGlobals
Expand Down Expand Up @@ -6083,7 +6093,10 @@ and remapOpExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (op,

and remapAppExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (e1, e1ty, tyargs, args, m) origExpr =
let e1R = remapExprImpl ctxt compgen tmenv e1
let e1tyR = remapPossibleForallTyImpl ctxt tmenv e1ty
let e1tyR =
match tmenv.realsig with
| false -> remapPossibleForallTyImpl ctxt tmenv e1ty
| true -> e1ty
let tyargsR = remapTypes tmenv tyargs
let argsR = remapExprs ctxt compgen tmenv args
if e1 === e1R && e1ty === e1tyR && tyargs === tyargsR && args === argsR then origExpr
Expand Down Expand Up @@ -6333,55 +6346,60 @@ and copyTycon compgen (tycon: Tycon) =
| _ -> Construct.NewClonedTycon tycon

/// This operates over a whole nested collection of tycons and vals simultaneously *)
and copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs =
and copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs =

let tyconsR = tycons |> List.map (copyTycon compgen)

let tmenvinner = bindTycons tycons tyconsR tmenv

// Values need to be copied and renamed.
let vsR, tmenvinner = copyAndRemapAndBindVals ctxt compgen tmenvinner vs

// "if a type constructor is hidden then all its inner values and inner type constructors must also be hidden"
// Hence we can just lookup the inner tycon/value mappings in the tables.

let lookupVal (v: Val) =
let vref =
try
let res = tmenvinner.valRemap[v]
res
with :? KeyNotFoundException ->
// Hence we can just lookup the inner tycon/value mappings in the tables.

let lookupVal (v: Val) =
let vref =
try
let res = tmenvinner.valRemap[v]
res
with :? KeyNotFoundException ->
errorR(InternalError(sprintf "couldn't remap internal value '%s'" v.LogicalName, v.Range))
mkLocalValRef v
vref.Deref

let lookupTycon tycon =
let tcref =
try
let lookupTycon tycon =
let tcref =
try
let res = tmenvinner.tyconRefRemap[mkLocalTyconRef tycon]
res
with :? KeyNotFoundException ->
with :? KeyNotFoundException ->
errorR(InternalError("couldn't remap internal tycon " + showL(DebugPrint.tyconL tycon), tycon.Range))
mkLocalTyconRef tycon
tcref.Deref

(tycons, tyconsR) ||> List.iter2 (fun tcd tcdR ->
(tycons, tyconsR)
||> List.iter2 (fun tcd tcdR ->
let lookupTycon tycon = lookupTycon tycon
let tpsR, tmenvinner2 = tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenvinner) tmenvinner (tcd.entity_typars.Force(tcd.entity_range))

tcdR.entity_typars <- LazyWithContext.NotLazy tpsR
tcdR.entity_attribs <- tcd.entity_attribs |> remapAttribs ctxt tmenvinner2
tcdR.entity_tycon_repr <- tcd.entity_tycon_repr |> remapTyconRepr ctxt tmenvinner2

let typeAbbrevR = tcd.TypeAbbrev |> Option.map (remapType tmenvinner2)

tcdR.entity_tycon_tcaug <- tcd.entity_tycon_tcaug |> remapTyconAug tmenvinner2
tcdR.entity_modul_type <- MaybeLazy.Strict (tcd.entity_modul_type.Value
|> mapImmediateValsAndTycons lookupTycon lookupVal)
tcdR.entity_modul_type <- MaybeLazy.Strict (tcd.entity_modul_type.Value |> mapImmediateValsAndTycons lookupTycon lookupVal)

let exnInfoR = tcd.ExceptionInfo |> remapTyconExnInfo ctxt tmenvinner2
match tcdR.entity_opt_data with
| Some optData -> tcdR.entity_opt_data <- Some { optData with entity_tycon_abbrev = typeAbbrevR; entity_exn_info = exnInfoR }
| _ ->
| _ ->
tcdR.SetTypeAbbrev typeAbbrevR
tcdR.SetExceptionInfo exnInfoR)
tyconsR, vsR, tmenvinner

tyconsR, vsR, tmenvinner

and allTyconsOfTycon (tycon: Tycon) =
seq { yield tycon
Expand Down

0 comments on commit a7eeda8

Please sign in to comment.