open System.Collections.Generic

open Internal.Utilities

open Microsoft.FSharp.Compiler.AbstractIL

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library

open Microsoft.FSharp.Compiler

open Microsoft.FSharp.Compiler.Range

open Microsoft.FSharp.Compiler.Rational

open Microsoft.FSharp.Compiler.Ast

open Microsoft.FSharp.Compiler.ErrorLogger

open Microsoft.FSharp.Compiler.Tast

open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics

open Microsoft.FSharp.Compiler.Lib

open Microsoft.FSharp.Compiler.TcGlobals

open Microsoft.FSharp.Compiler.Layout

open Microsoft.FSharp.Compiler.Layout.TaggedTextOps

open Microsoft.FSharp.Compiler.PrettyNaming

#if EXTENSIONTYPING

open Microsoft.FSharp.Compiler.ExtensionTyping

type TyparMap<'T> =

| TPMap of StampMap<'T>

member tm.Item with get (v: Typar) = let (TPMap m) = tm in m.[v.Stamp]

member tm.ContainsKey (v: Typar) = let (TPMap m) = tm in m.ContainsKey(v.Stamp)

member tm.Add (v: Typar, x) = let (TPMap m) = tm in TPMap (m.Add(v.Stamp,x))

static member Empty : TyparMap<'T> = TPMap Map.empty

type TyconRefMap<'T>(imap: StampMap<'T>) =

member m.Item with get (v: TyconRef) = imap.[v.Stamp]

member m.TryFind (v: TyconRef) = imap.TryFind v.Stamp

member m.ContainsKey (v: TyconRef) = imap.ContainsKey v.Stamp

member m.Add (v: TyconRef) x = TyconRefMap (imap.Add (v.Stamp,x))

member m.Remove (v: TyconRef) = TyconRefMap (imap.Remove v.Stamp)

member m.IsEmpty = imap.IsEmpty

static member Empty : TyconRefMap<'T> = TyconRefMap Map.empty

static member OfList vs = (vs, TyconRefMap<'T>.Empty) ||> List.foldBack (fun (x,y) acc -> acc.Add x y)

type ValMap<'T>(imap: StampMap<'T>) =

member m.Contents = imap

member m.Item with get (v:Val) = imap.[v.Stamp]

member m.TryFind (v: Val) = imap.TryFind v.Stamp

member m.ContainsVal (v: Val) = imap.ContainsKey v.Stamp

member m.Add (v: Val) x = ValMap (imap.Add(v.Stamp,x))

member m.Remove (v: Val) = ValMap (imap.Remove(v.Stamp))

static member Empty = ValMap<'T> Map.empty

member m.IsEmpty = imap.IsEmpty

static member OfList vs = (vs, ValMap<'T>.Empty) ||> List.foldBack (fun (x,y) acc -> acc.Add x y)

type TyparInst = (Typar * TType) list

type TyconRefRemap = TyconRefMap<TyconRef>

type ValRemap = ValMap<ValRef>

let emptyTyconRefRemap : TyconRefRemap = TyconRefMap<_>.Empty

let emptyTyparInst = ([] : TyparInst)

type Remap =

{ tpinst : TyparInst;

valRemap: ValRemap;

tyconRefRemap : TyconRefRemap;

removeTraitSolutions: bool }

let emptyRemap =

{ tpinst = emptyTyparInst;

tyconRefRemap = emptyTyconRefRemap;

valRemap = ValMap.Empty;

removeTraitSolutions = false }

type Remap with

static member Empty = emptyRemap

let addTyconRefRemap tcref1 tcref2 tmenv =

{tmenv with tyconRefRemap=tmenv.tyconRefRemap.Add tcref1 tcref2 }

let isRemapEmpty remap =

isNil remap.tpinst &&

remap.tyconRefRemap.IsEmpty &&

remap.valRemap.IsEmpty

let rec instTyparRef tpinst ty tp =

match tpinst with

| [] -> ty

| (tp',ty')::t ->

if typarEq tp tp' then ty'

else instTyparRef t ty tp

let instMeasureTyparRef tpinst unt (tp:Typar) =

match tp.Kind with

| TyparKind.Measure ->

let rec loop tpinst =

match tpinst with

| [] -> unt

| (tp',ty')::t ->

if typarEq tp tp' then

match ty' with

| TType_measure unt -> unt

| _ -> failwith "instMeasureTyparRef incorrect kind";

else

loop t

loop tpinst

| _ -> failwith "instMeasureTyparRef: kind=Type"

let remapTyconRef (tcmap: TyconRefMap<_>) tcr =

match tcmap.TryFind tcr with

| Some tcr -> tcr

| None -> tcr

let remapUnionCaseRef tcmap (UCRef(tcref,nm)) = UCRef(remapTyconRef tcmap tcref,nm)

let remapRecdFieldRef tcmap (RFRef(tcref,nm)) = RFRef(remapTyconRef tcmap tcref,nm)

let mkTyparInst (typars: Typars) tyargs =

#if CHECKED

if List.length typars <> List.length tyargs then

failwith ("mkTyparInst: invalid type" + (sprintf " %d <> %d" (List.length typars) (List.length tyargs)));

(List.zip typars tyargs : TyparInst)

let generalizeTypar tp = mkTyparTy tp

let generalizeTypars tps = List.map generalizeTypar tps

let rec remapTypeAux (tyenv : Remap) (ty:TType) =

let ty = stripTyparEqns ty

match ty with

| TType_var tp as ty -> instTyparRef tyenv.tpinst ty tp

| TType_app (tcr,tinst) as ty ->

match tyenv.tyconRefRemap.TryFind tcr with

| Some tcr' -> TType_app (tcr',remapTypesAux tyenv tinst)

| None ->

match tinst with

| [] -> ty // optimization to avoid re-allocation of TType_app node in the common case

| _ ->

// avoid reallocation on idempotent

let tinst' = remapTypesAux tyenv tinst

if tinst === tinst' then ty else

TType_app (tcr,tinst')

| TType_ucase (UCRef(tcr,n),tinst) ->

match tyenv.tyconRefRemap.TryFind tcr with

| Some tcr' -> TType_ucase (UCRef(tcr',n),remapTypesAux tyenv tinst)

| None -> TType_ucase (UCRef(tcr,n),remapTypesAux tyenv tinst)

| TType_tuple (tupInfo, l) as ty ->

let tupInfo' = remapTupInfoAux tyenv tupInfo

let l' = remapTypesAux tyenv l

if tupInfo === tupInfo' && l === l' then ty else

TType_tuple (tupInfo', l')

| TType_fun (d,r) as ty ->

let d' = remapTypeAux tyenv d

let r' = remapTypeAux tyenv r

if d === d' && r === r' then ty else

TType_fun (d', r')

| TType_forall (tps,ty) ->

let tps',tyenv = copyAndRemapAndBindTypars tyenv tps

TType_forall (tps', remapTypeAux tyenv ty)

| TType_measure unt ->

TType_measure (remapMeasureAux tyenv unt)

and remapMeasureAux tyenv unt =

match unt with

| Measure.One -> unt

| Measure.Con tcr ->

match tyenv.tyconRefRemap.TryFind tcr with

| Some tcr -> Measure.Con tcr

| None -> unt

| Measure.Prod(u1,u2) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2)

| Measure.RationalPower(u,q) -> Measure.RationalPower(remapMeasureAux tyenv u, q)

| Measure.Inv u -> Measure.Inv(remapMeasureAux tyenv u)

| Measure.Var tp as unt ->

match tp.Solution with

| None ->

if ListAssoc.containsKey typarEq tp tyenv.tpinst then

match ListAssoc.find typarEq tp tyenv.tpinst with

| TType_measure unt -> unt

| _ -> failwith "remapMeasureAux: incorrect kinds"

else unt

| Some (TType_measure unt) -> remapMeasureAux tyenv unt

| Some ty -> failwithf "incorrect kinds: %A" ty

and remapTupInfoAux _tyenv unt =

match unt with

| TupInfo.Const _ -> unt

and remapTypesAux tyenv types = List.mapq (remapTypeAux tyenv) types

and remapTyparConstraintsAux tyenv cs =

cs |> List.choose (fun x ->

match x with

| TyparConstraint.CoercesTo(ty,m) ->

Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty,m))

| TyparConstraint.MayResolveMember(traitInfo,m) ->

Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m))

| TyparConstraint.DefaultsTo(priority,ty,m) -> Some(TyparConstraint.DefaultsTo(priority,remapTypeAux tyenv ty,m))

| TyparConstraint.IsEnum(uty,m) ->

Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty,m))

| TyparConstraint.IsDelegate(uty1,uty2,m) ->

Some(TyparConstraint.IsDelegate(remapTypeAux tyenv uty1,remapTypeAux tyenv uty2,m))

| TyparConstraint.SimpleChoice(tys,m) -> Some(TyparConstraint.SimpleChoice(remapTypesAux tyenv tys,m))

| TyparConstraint.SupportsComparison _

| TyparConstraint.SupportsEquality _

| TyparConstraint.SupportsNull _

| TyparConstraint.IsUnmanaged _

| TyparConstraint.IsNonNullableStruct _

| TyparConstraint.IsReferenceType _

| TyparConstraint.RequiresDefaultConstructor _ -> Some(x))

and remapTraitAux tyenv (TTrait(typs,nm,mf,argtys,rty,slnCell)) =

let slnCell =

match !slnCell with

| None -> None

| _ when tyenv.removeTraitSolutions -> None

| Some sln ->

let sln =

match sln with

| ILMethSln(typ,extOpt,ilMethRef,minst) ->

ILMethSln(remapTypeAux tyenv typ,extOpt,ilMethRef,remapTypesAux tyenv minst)

| FSMethSln(typ, vref,minst) ->

FSMethSln(remapTypeAux tyenv typ, remapValRef tyenv vref,remapTypesAux tyenv minst)

| FSRecdFieldSln(tinst, rfref, isSet) ->

FSRecdFieldSln(remapTypesAux tyenv tinst, remapRecdFieldRef tyenv.tyconRefRemap rfref, isSet)

| BuiltInSln ->

BuiltInSln

| ClosedExprSln e ->

ClosedExprSln e // no need to remap because it is a closed expression, referring only to external types

Some sln

// Note: we reallocate a new solution cell on every traversal of a trait constraint

// This feels incorrect for trait constraints that are quantified: it seems we should have

// formal binders for trait constraints when they are quantified, just as

// we have formal binders for type variables.

//

// The danger here is that a solution for one syntactic occurrence of a trait constraint won't

// be propagated to other, "linked" solutions. However trait constraints don't appear in any algebrra

// in the same way as types

TTrait(remapTypesAux tyenv typs,nm,mf,remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty,ref slnCell)

and bindTypars tps tyargs tpinst =

match tps with

| [] -> tpinst

| _ -> List.map2 (fun tp tyarg -> (tp,tyarg)) tps tyargs @ tpinst

and copyAndRemapAndBindTyparsFull remapAttrib tyenv tps =

match tps with

| [] -> tps,tyenv

| _ ->

let tps' = copyTypars tps

let tyenv = { tyenv with tpinst = bindTypars tps (generalizeTypars tps') tyenv.tpinst }

(tps,tps') ||> List.iter2 (fun tporig tp ->

tp.FixupConstraints (remapTyparConstraintsAux tyenv tporig.Constraints);

tp.typar_attribs <- tporig.typar_attribs |> remapAttrib) ;

tps',tyenv

and copyAndRemapAndBindTypars tyenv tps =

copyAndRemapAndBindTyparsFull (fun _ -> []) tyenv tps

and remapValLinkage tyenv (vlink: ValLinkageFullKey) =

let tyOpt = vlink.TypeForLinkage

let tyOpt' =

match tyOpt with

| None -> tyOpt

| Some ty ->

let ty' = remapTypeAux tyenv ty

if ty === ty' then tyOpt else

Some ty'

if tyOpt === tyOpt' then vlink else

ValLinkageFullKey(vlink.PartialKey, tyOpt')

and remapNonLocalValRef tyenv (nlvref:NonLocalValOrMemberRef) =

let eref = nlvref.EnclosingEntity

let eref' = remapTyconRef tyenv.tyconRefRemap eref

let vlink = nlvref.ItemKey

let vlink' = remapValLinkage tyenv vlink

if eref === eref' && vlink === vlink' then nlvref else

{ EnclosingEntity = eref'

ItemKey = vlink' }

and remapValRef tmenv (vref: ValRef) =

match tmenv.valRemap.TryFind vref.Deref with

| None ->

if vref.IsLocalRef then vref else

let nlvref = vref.nlr

let nlvref' = remapNonLocalValRef tmenv nlvref

if nlvref === nlvref' then vref else

VRefNonLocal nlvref'

| Some res ->

res

let remapType tyenv x =

if isRemapEmpty tyenv then x else

remapTypeAux tyenv x

let remapTypes tyenv x =

if isRemapEmpty tyenv then x else

remapTypesAux tyenv x

let remapTypeFull remapAttrib tyenv ty =

if isRemapEmpty tyenv then ty else

match stripTyparEqns ty with

| TType_forall(tps,tau) ->

let tps',tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv tps

TType_forall(tps',remapType tyenvinner tau)

| _ ->

remapType tyenv ty

let remapParam tyenv (TSlotParam(nm,typ,fl1,fl2,fl3,attribs) as x) =

if isRemapEmpty tyenv then x else

TSlotParam(nm,remapTypeAux tyenv typ,fl1,fl2,fl3,attribs)

let remapSlotSig remapAttrib tyenv (TSlotSig(nm,typ, ctps,methTypars,paraml, rty) as x) =

if isRemapEmpty tyenv then x else

let typ' = remapTypeAux tyenv typ

let ctps',tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv ctps

let methTypars',tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenvinner methTypars

TSlotSig(nm,typ', ctps',methTypars',List.mapSquared (remapParam tyenvinner) paraml,Option.map (remapTypeAux tyenvinner) rty)

let mkInstRemap tpinst =

{ tyconRefRemap = emptyTyconRefRemap;

tpinst = tpinst;

valRemap = ValMap.Empty;

removeTraitSolutions = false }

let instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst) x

let instTypes tpinst x = if isNil tpinst then x else remapTypesAux (mkInstRemap tpinst) x

let instTrait tpinst x = if isNil tpinst then x else remapTraitAux (mkInstRemap tpinst) x

let instTyparConstraints tpinst x = if isNil tpinst then x else remapTyparConstraintsAux (mkInstRemap tpinst) x

let instSlotSig tpinst ss = remapSlotSig (fun _ -> []) (mkInstRemap tpinst) ss

let copySlotSig ss = remapSlotSig (fun _ -> []) Remap.Empty ss

let mkTyparToTyparRenaming tpsOrig tps =

let tinst = generalizeTypars tps

mkTyparInst tpsOrig tinst,tinst

let mkTyconInst (tycon:Tycon) tinst = mkTyparInst tycon.TyparsNoRange tinst

let mkTyconRefInst (tcref:TyconRef) tinst = mkTyconInst tcref.Deref tinst

let tyconRefEq (g:TcGlobals) tcref1 tcref2 = primEntityRefEq g.compilingFslib g.fslibCcu tcref1 tcref2

let valRefEq (g:TcGlobals) vref1 vref2 = primValRefEq g.compilingFslib g.fslibCcu vref1 vref2

let reduceTyconRefAbbrevMeasureable (tcref:TyconRef) =

let abbrev = tcref.TypeAbbrev

match abbrev with

| Some (TType_measure ms) -> ms

| _ -> invalidArg "tcref" "not a measure abbreviation, or incorrect kind"

let rec stripUnitEqnsFromMeasureAux canShortcut unt =

match stripUnitEqnsAux canShortcut unt with

| Measure.Con tcref when tcref.IsTypeAbbrev ->

stripUnitEqnsFromMeasureAux canShortcut (reduceTyconRefAbbrevMeasureable tcref)

| m -> m

let stripUnitEqnsFromMeasure m = stripUnitEqnsFromMeasureAux false m

let rec MeasureExprConExponent g abbrev ucref unt =

match (if abbrev then stripUnitEqnsFromMeasure unt else stripUnitEqns unt) with

| Measure.Con ucref' -> if tyconRefEq g ucref' ucref then OneRational else ZeroRational

| Measure.Inv unt' -> NegRational(MeasureExprConExponent g abbrev ucref unt')

| Measure.Prod(unt1,unt2) -> AddRational(MeasureExprConExponent g abbrev ucref unt1) (MeasureExprConExponent g abbrev ucref unt2)

| Measure.RationalPower(unt',q) -> MulRational (MeasureExprConExponent g abbrev ucref unt') q

| _ -> ZeroRational

let rec MeasureConExponentAfterRemapping g r ucref unt =

match stripUnitEqnsFromMeasure unt with

| Measure.Con ucref' -> if tyconRefEq g (r ucref') ucref then OneRational else ZeroRational

| Measure.Inv unt' -> NegRational(MeasureConExponentAfterRemapping g r ucref unt')

| Measure.Prod(unt1,unt2) -> AddRational(MeasureConExponentAfterRemapping g r ucref unt1) (MeasureConExponentAfterRemapping g r ucref unt2)

| Measure.RationalPower(unt',q) -> MulRational (MeasureConExponentAfterRemapping g r ucref unt') q

| _ -> ZeroRational

let rec MeasureVarExponent tp unt =

match stripUnitEqnsFromMeasure unt with

| Measure.Var tp' -> if typarEq tp tp' then OneRational else ZeroRational

| Measure.Inv unt' -> NegRational(MeasureVarExponent tp unt')

| Measure.Prod(unt1,unt2) -> AddRational(MeasureVarExponent tp unt1) (MeasureVarExponent tp unt2)

| Measure.RationalPower(unt',q) -> MulRational (MeasureVarExponent tp unt') q

| _ -> ZeroRational

let ListMeasureVarOccs unt =

let rec gather acc unt =

match stripUnitEqnsFromMeasure unt with

Measure.Var tp -> if List.exists (typarEq tp) acc then acc else tp::acc

| Measure.Prod(unt1,unt2) -> gather (gather acc unt1) unt2

| Measure.RationalPower(unt',_) -> gather acc unt'

| Measure.Inv unt' -> gather acc unt'

| _ -> acc

gather [] unt

let ListMeasureVarOccsWithNonZeroExponents untexpr =

let rec gather acc unt =

match stripUnitEqnsFromMeasure unt with

| Measure.Var tp ->

if List.exists (fun (tp', _) -> typarEq tp tp') acc then acc

else let e = MeasureVarExponent tp untexpr in if e = ZeroRational then acc else (tp,e)::acc

| Measure.Prod(unt1,unt2) -> gather (gather acc unt1) unt2

| Measure.Inv unt' -> gather acc unt'

| Measure.RationalPower(unt',_) -> gather acc unt'

| _ -> acc

gather [] untexpr

let ListMeasureConOccsWithNonZeroExponents g eraseAbbrevs untexpr =

let rec gather acc unt =

match (if eraseAbbrevs then stripUnitEqnsFromMeasure unt else stripUnitEqns unt) with

| Measure.Con c ->

if List.exists (fun (c', _) -> tyconRefEq g c c') acc then acc else

let e = MeasureExprConExponent g eraseAbbrevs c untexpr in if e = ZeroRational then acc else (c,e)::acc

| Measure.Prod(unt1,unt2) -> gather (gather acc unt1) unt2

| Measure.Inv unt' -> gather acc unt'

| Measure.RationalPower(unt',_) -> gather acc unt'

| _ -> acc

gather [] untexpr

let ListMeasureConOccsAfterRemapping g r unt =

let rec gather acc unt =

match (stripUnitEqnsFromMeasure unt) with

| Measure.Con c -> if List.exists (tyconRefEq g (r c)) acc then acc else r c::acc

| Measure.Prod(unt1,unt2) -> gather (gather acc unt1) unt2

| Measure.RationalPower(unt',_) -> gather acc unt'

| Measure.Inv unt' -> gather acc unt'

| _ -> acc

gather [] unt

let MeasurePower u n =

if n=0 then Measure.One

elif n=1 then u

else Measure.RationalPower (u, intToRational n)

let MeasureProdOpt m1 m2 =

match m1, m2 with

| Measure.One, _ -> m2

| _, Measure.One -> m1

| _, _ -> Measure.Prod (m1,m2)

let ProdMeasures ms = match ms with [] -> Measure.One | m::ms -> List.foldBack MeasureProdOpt ms m

let isDimensionless g tyarg =

match stripTyparEqns tyarg with

| TType_measure unt ->

isNil (ListMeasureVarOccsWithNonZeroExponents unt) &&

isNil (ListMeasureConOccsWithNonZeroExponents g true unt)

| _ -> false

let destUnitParMeasure g unt =

let vs = ListMeasureVarOccsWithNonZeroExponents unt

let cs = ListMeasureConOccsWithNonZeroExponents g true unt

match vs, cs with

| [(v,e)], [] when e = OneRational -> v

| _, _ -> failwith "destUnitParMeasure: not a unit-of-measure parameter"

let isUnitParMeasure g unt =

let vs = ListMeasureVarOccsWithNonZeroExponents unt

let cs = ListMeasureConOccsWithNonZeroExponents g true unt

match vs, cs with

| [(_,e)], [] when e = OneRational -> true

| _, _ -> false

let normalizeMeasure g ms =

let vs = ListMeasureVarOccsWithNonZeroExponents ms

let cs = ListMeasureConOccsWithNonZeroExponents g false ms

match vs, cs with

| [],[] -> Measure.One

| [(v,e)], [] when e = OneRational -> Measure.Var v

| vs, cs -> List.foldBack (fun (v,e) -> fun m -> Measure.Prod (Measure.RationalPower (Measure.Var v, e), m)) vs (List.foldBack (fun (c,e) -> fun m -> Measure.Prod (Measure.RationalPower (Measure.Con c, e), m)) cs Measure.One)

let tryNormalizeMeasureInType g ty =

match ty with

| TType_measure (Measure.Var v) ->

match v.Solution with

| Some (TType_measure ms) ->

(v.typar_solution <- Some (TType_measure (normalizeMeasure g ms)); ty)

| _ -> ty

| _ -> ty

let mkNativePtrTy (g:TcGlobals) ty = TType_app (g.nativeptr_tcr, [ty])

let mkByrefTy (g:TcGlobals) ty = TType_app (g.byref_tcr, [ty])

let mkArrayTy (g:TcGlobals) rank ty m =

if rank < 1 || rank > 32 then

// TODO : Provide a better message for zero/negative inputs here.

errorR(Error(FSComp.SR.tastopsMaxArrayThirtyTwo(),m));

TType_app (g.il_arr_tcr_map.[3], [ty])

else

TType_app (g.il_arr_tcr_map.[rank - 1], [ty])

let maxTuple = 8

let goodTupleFields = maxTuple-1

let isCompiledTupleTyconRef g tcref =

match tcref with

| x when

(tyconRefEq g g.ref_tuple1_tcr x ||

tyconRefEq g g.ref_tuple2_tcr x ||

tyconRefEq g g.ref_tuple3_tcr x ||

tyconRefEq g g.ref_tuple4_tcr x ||

tyconRefEq g g.ref_tuple5_tcr x ||

tyconRefEq g g.ref_tuple6_tcr x ||

tyconRefEq g g.ref_tuple7_tcr x ||

tyconRefEq g g.ref_tuple8_tcr x ||

tyconRefEq g g.struct_tuple1_tcr x ||

tyconRefEq g g.struct_tuple2_tcr x ||

tyconRefEq g g.struct_tuple3_tcr x ||

tyconRefEq g g.struct_tuple4_tcr x ||

tyconRefEq g g.struct_tuple5_tcr x ||

tyconRefEq g g.struct_tuple6_tcr x ||

tyconRefEq g g.struct_tuple7_tcr x ||

tyconRefEq g g.struct_tuple8_tcr x) -> true

| _ -> false

let mkCompiledTupleTyconRef (g:TcGlobals) isStruct tys =

let n = List.length tys

if n = 1 then (if isStruct then g.struct_tuple1_tcr else g.ref_tuple1_tcr)

elif n = 2 then (if isStruct then g.struct_tuple2_tcr else g.ref_tuple2_tcr)

elif n = 3 then (if isStruct then g.struct_tuple3_tcr else g.ref_tuple3_tcr)

elif n = 4 then (if isStruct then g.struct_tuple4_tcr else g.ref_tuple4_tcr)

elif n = 5 then (if isStruct then g.struct_tuple5_tcr else g.ref_tuple5_tcr)

elif n = 6 then (if isStruct then g.struct_tuple6_tcr else g.ref_tuple6_tcr)

elif n = 7 then (if isStruct then g.struct_tuple7_tcr else g.ref_tuple7_tcr)

elif n = 8 then (if isStruct then g.struct_tuple8_tcr else g.ref_tuple8_tcr)

else failwithf "mkCompiledTupleTyconRef, n = %d" n

let rec mkCompiledTupleTy g isStruct tys =

let n = List.length tys

if n < maxTuple then TType_app (mkCompiledTupleTyconRef g isStruct tys, tys)

else

let tysA,tysB = List.splitAfter goodTupleFields tys

TType_app ((if isStruct then g.struct_tuple8_tcr else g.ref_tuple8_tcr), tysA@[mkCompiledTupleTy g isStruct tysB])

let applyTyconAbbrev abbrevTy tycon tyargs =

if isNil tyargs then abbrevTy

else instType (mkTyconInst tycon tyargs) abbrevTy

let reduceTyconAbbrev (tycon:Tycon) tyargs =

let abbrev = tycon.TypeAbbrev

match abbrev with

| None -> invalidArg "tycon" "this type definition is not an abbreviation";

| Some abbrevTy ->

applyTyconAbbrev abbrevTy tycon tyargs

let reduceTyconRefAbbrev (tcref:TyconRef) tyargs =

reduceTyconAbbrev tcref.Deref tyargs

let reduceTyconMeasureableOrProvided (g:TcGlobals) (tycon:Tycon) tyargs =

ignore g

let repr = tycon.TypeReprInfo

match repr with

| TMeasureableRepr ty ->

if isNil tyargs then ty else instType (mkTyconInst tycon tyargs) ty

#if EXTENSIONTYPING

| TProvidedTypeExtensionPoint info when info.IsErased -> info.BaseTypeForErased (range0, g.obj_ty)

| _ -> invalidArg "tc" "this type definition is not a refinement"

let reduceTyconRefMeasureableOrProvided (g:TcGlobals) (tcref:TyconRef) tyargs =

reduceTyconMeasureableOrProvided g tcref.Deref tyargs

let rec stripTyEqnsA g canShortcut ty =

let ty = stripTyparEqnsAux canShortcut ty

match ty with

| TType_app (tcref,tinst) ->

let tycon = tcref.Deref

match tycon.TypeAbbrev with

| Some abbrevTy ->

stripTyEqnsA g canShortcut (applyTyconAbbrev abbrevTy tycon tinst)

| None ->

if tycon.IsMeasureableReprTycon && List.forall (isDimensionless g) tinst then

stripTyEqnsA g canShortcut (reduceTyconMeasureableOrProvided g tycon tinst)

else

ty

| ty -> ty

let stripTyEqns g ty = stripTyEqnsA g false ty

let evalTupInfoIsStruct aexpr =

match aexpr with

| TupInfo.Const b -> b

let rec stripTyEqnsAndErase eraseFuncAndTuple (g:TcGlobals) ty =

let ty = stripTyEqns g ty

match ty with

| TType_app (tcref,args) ->

let tycon = tcref.Deref

if tycon.IsErased then

stripTyEqnsAndErase eraseFuncAndTuple g (reduceTyconMeasureableOrProvided g tycon args)

elif tyconRefEq g tcref g.nativeptr_tcr && eraseFuncAndTuple then

stripTyEqnsAndErase eraseFuncAndTuple g g.nativeint_ty

else

ty

| TType_fun(a,b) when eraseFuncAndTuple -> TType_app(g.fastFunc_tcr,[ a; b])

| TType_tuple(tupInfo,l) when eraseFuncAndTuple -> mkCompiledTupleTy g (evalTupInfoIsStruct tupInfo) l

| ty -> ty

let stripTyEqnsAndMeasureEqns g ty =

stripTyEqnsAndErase false g ty

type Erasure = EraseAll | EraseMeasures | EraseNone

let stripTyEqnsWrtErasure erasureFlag g ty =

match erasureFlag with

| EraseAll -> stripTyEqnsAndErase true g ty

| EraseMeasures -> stripTyEqnsAndErase false g ty

| _ -> stripTyEqns g ty

let rec stripExnEqns (eref:TyconRef) =

let exnc = eref.Deref

match exnc.ExceptionInfo with

| TExnAbbrevRepr eref -> stripExnEqns eref

| _ -> exnc

let primDestForallTy g ty = ty |> stripTyEqns g |> (function TType_forall (tyvs,tau) -> (tyvs,tau) | _ -> failwith "primDestForallTy: not a forall type")

let destFunTy g ty = ty |> stripTyEqns g |> (function TType_fun (tyv,tau) -> (tyv,tau) | _ -> failwith "destFunTy: not a function type")

let destAnyTupleTy g ty = ty |> stripTyEqns g |> (function TType_tuple (tupInfo,l) -> tupInfo,l | _ -> failwith "destAnyTupleTy: not a tuple type")

let destRefTupleTy g ty = ty |> stripTyEqns g |> (function TType_tuple (tupInfo,l) when not (evalTupInfoIsStruct tupInfo) -> l | _ -> failwith "destRefTupleTy: not a reference tuple type")

let destStructTupleTy g ty = ty |> stripTyEqns g |> (function TType_tuple (tupInfo,l) when evalTupInfoIsStruct tupInfo -> l | _ -> failwith "destStructTupleTy: not a struct tuple type")

let destTyparTy g ty = ty |> stripTyEqns g |> (function TType_var v -> v | _ -> failwith "destTyparTy: not a typar type")

let destAnyParTy g ty = ty |> stripTyEqns g |> (function TType_var v -> v | TType_measure unt -> destUnitParMeasure g unt | _ -> failwith "destAnyParTy: not a typar or unpar type")

let destMeasureTy g ty = ty |> stripTyEqns g |> (function TType_measure m -> m | _ -> failwith "destMeasureTy: not a unit-of-measure type")

let isFunTy g ty = ty |> stripTyEqns g |> (function TType_fun _ -> true | _ -> false)

let isForallTy g ty = ty |> stripTyEqns g |> (function TType_forall _ -> true | _ -> false)

let isAnyTupleTy g ty = ty |> stripTyEqns g |> (function TType_tuple _ -> true | _ -> false)

let isRefTupleTy g ty = ty |> stripTyEqns g |> (function TType_tuple (tupInfo,_) -> not (evalTupInfoIsStruct tupInfo) | _ -> false)

let isStructTupleTy g ty = ty |> stripTyEqns g |> (function TType_tuple (tupInfo,_) -> evalTupInfoIsStruct tupInfo | _ -> false)

let isUnionTy g ty = ty |> stripTyEqns g |> (function TType_app(tcr,_) -> tcr.IsUnionTycon | _ -> false)

let isReprHiddenTy g ty = ty |> stripTyEqns g |> (function TType_app(tcr,_) -> tcr.IsHiddenReprTycon | _ -> false)

let isFSharpObjModelTy g ty = ty |> stripTyEqns g |> (function TType_app(tcr,_) -> tcr.IsFSharpObjectModelTycon | _ -> false)

let isRecdTy g ty = ty |> stripTyEqns g |> (function TType_app(tcr,_) -> tcr.IsRecordTycon | _ -> false)

let isTyparTy g ty = ty |> stripTyEqns g |> (function TType_var _ -> true | _ -> false)

let isAnyParTy g ty = ty |> stripTyEqns g |> (function TType_var _ -> true | TType_measure unt -> isUnitParMeasure g unt | _ -> false)

let isMeasureTy g ty = ty |> stripTyEqns g |> (function TType_measure _ -> true | _ -> false)

let isProvenUnionCaseTy ty = match ty with TType_ucase _ -> true | _ -> false

let mkAppTy tcref tyargs = TType_app(tcref,tyargs)

let mkProvenUnionCaseTy ucref tyargs = TType_ucase(ucref,tyargs)

let isAppTy g ty = ty |> stripTyEqns g |> (function TType_app _ -> true | _ -> false)

let destAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,tinst) -> tcref,tinst | _ -> failwith "destAppTy")

let tcrefOfAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tcref | _ -> failwith "tcrefOfAppTy")

let argsOfAppTy g ty = ty |> stripTyEqns g |> (function TType_app(_,tinst) -> tinst | _ -> [])

let tryDestTyparTy g ty = ty |> stripTyEqns g |> (function TType_var v -> Some v | _ -> None)

let tryDestFunTy g ty = ty |> stripTyEqns g |> (function TType_fun (tyv,tau) -> Some(tyv,tau) | _ -> None)

let tryDestAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> Some tcref | _ -> None)

let tryAnyParTy g ty = ty |> stripTyEqns g |> (function TType_var v -> Some v | TType_measure unt when isUnitParMeasure g unt -> Some(destUnitParMeasure g unt) | _ -> None)

let (|AppTy|_|) g ty = ty |> stripTyEqns g |> (function TType_app(tcref,tinst) -> Some (tcref,tinst) | _ -> None)

let (|RefTupleTy|_|) g ty = ty |> stripTyEqns g |> (function TType_tuple(tupInfo,tys) when not (evalTupInfoIsStruct tupInfo) -> Some tys | _ -> None)

let (|FunTy|_|) g ty = ty |> stripTyEqns g |> (function TType_fun(dty, rty) -> Some (dty, rty) | _ -> None)

let tyconOfAppTy g ty = (tcrefOfAppTy g ty).Deref

let tryNiceEntityRefOfTy ty =

let ty = stripTyparEqnsAux false ty

match ty with

| TType_app (tcref,_) -> Some tcref

| TType_measure (Measure.Con tcref) -> Some tcref

| _ -> None

let (|NullableTy|_|) g ty =

match ty with

| AppTy g (tcr,[tyarg]) when tyconRefEq g tcr g.system_Nullable_tcref -> Some tyarg

| _ -> None

let (|StripNullableTy|) g ty =

match ty with

| AppTy g (tcr,[tyarg]) when tyconRefEq g tcr g.system_Nullable_tcref -> tyarg

| _ -> ty

let (|ByrefTy|_|) g ty =

match ty with

| AppTy g (tcr,[tyarg]) when tyconRefEq g tcr g.byref_tcr -> Some tyarg

| _ -> None

let mkInstForAppTy g typ =

match typ with

| AppTy g (tcref,tinst) -> mkTyconRefInst tcref tinst

| _ -> []

let domainOfFunTy g ty = fst(destFunTy g ty)

let rangeOfFunTy g ty = snd(destFunTy g ty)

type TypeEquivEnv =

{ EquivTypars: TyparMap<TType>;

EquivTycons: TyconRefRemap}

let typeEquivEnvEmpty =

{ EquivTypars = TyparMap.Empty;

EquivTycons = emptyTyconRefRemap }

type TypeEquivEnv with

static member Empty = typeEquivEnvEmpty

member aenv.BindTyparsToTypes tps1 tys2 =

{aenv with EquivTypars= (tps1,tys2,aenv.EquivTypars) |||> List.foldBack2 (fun tp ty tpmap -> tpmap.Add(tp,ty)) }

member aenv.BindEquivTypars tps1 tps2 =

aenv.BindTyparsToTypes tps1 (List.map mkTyparTy tps2)

static member FromTyparInst tpinst =

let tps,tys = List.unzip tpinst

TypeEquivEnv.Empty.BindTyparsToTypes tps tys

static member FromEquivTypars tps1 tps2 =

TypeEquivEnv.Empty.BindEquivTypars tps1 tps2

let rec traitsAEquivAux erasureFlag g aenv (TTrait(typs1,nm,mf1,argtys,rty,_)) (TTrait(typs2,nm2,mf2,argtys2,rty2,_)) =

ListSet.equals (typeAEquivAux erasureFlag g aenv) typs1 typs2 &&

mf1 = mf2 &&

returnTypesAEquivAux erasureFlag g aenv rty rty2 &&

List.lengthsEqAndForall2 (typeAEquivAux erasureFlag g aenv) argtys argtys2 &&

nm = nm2

and returnTypesAEquivAux erasureFlag g aenv rty rty2 =

match rty,rty2 with

| None,None -> true

| Some t1,Some t2 -> typeAEquivAux erasureFlag g aenv t1 t2

| _ -> false

and typarConstraintsAEquivAux erasureFlag g aenv tpc1 tpc2 =

match tpc1,tpc2 with

| TyparConstraint.CoercesTo(acty,_),

TyparConstraint.CoercesTo(fcty,_) ->

typeAEquivAux erasureFlag g aenv acty fcty

| TyparConstraint.MayResolveMember(trait1,_),

TyparConstraint.MayResolveMember(trait2,_) ->

traitsAEquivAux erasureFlag g aenv trait1 trait2

| TyparConstraint.DefaultsTo(_,acty,_),

TyparConstraint.DefaultsTo(_,fcty,_) ->

typeAEquivAux erasureFlag g aenv acty fcty

| TyparConstraint.IsEnum(uty1,_),TyparConstraint.IsEnum(uty2,_) ->

typeAEquivAux erasureFlag g aenv uty1 uty2

| TyparConstraint.IsDelegate(aty1,bty1,_),TyparConstraint.IsDelegate(aty2,bty2,_) ->

typeAEquivAux erasureFlag g aenv aty1 aty2 &&

typeAEquivAux erasureFlag g aenv bty1 bty2

| TyparConstraint.SimpleChoice (tys1,_),TyparConstraint.SimpleChoice(tys2,_) ->

ListSet.equals (typeAEquivAux erasureFlag g aenv) tys1 tys2

| TyparConstraint.SupportsComparison _ ,TyparConstraint.SupportsComparison _

| TyparConstraint.SupportsEquality _ ,TyparConstraint.SupportsEquality _

| TyparConstraint.SupportsNull _ ,TyparConstraint.SupportsNull _

| TyparConstraint.IsNonNullableStruct _ ,TyparConstraint.IsNonNullableStruct _

| TyparConstraint.IsReferenceType _ ,TyparConstraint.IsReferenceType _

| TyparConstraint.IsUnmanaged _ ,TyparConstraint.IsUnmanaged _

| TyparConstraint.RequiresDefaultConstructor _, TyparConstraint.RequiresDefaultConstructor _ -> true

| _ -> false

and typarConstraintSetsAEquivAux erasureFlag g aenv (tp1:Typar) (tp2:Typar) =

tp1.StaticReq = tp2.StaticReq &&

ListSet.equals (typarConstraintsAEquivAux erasureFlag g aenv) tp1.Constraints tp2.Constraints

and typarsAEquivAux erasureFlag g (aenv: TypeEquivEnv) tps1 tps2 =

List.length tps1 = List.length tps2 &&

let aenv = aenv.BindEquivTypars tps1 tps2

List.forall2 (typarConstraintSetsAEquivAux erasureFlag g aenv) tps1 tps2

and tcrefAEquiv g aenv tc1 tc2 =

tyconRefEq g tc1 tc2 ||

(aenv.EquivTycons.ContainsKey tc1 && tyconRefEq g aenv.EquivTycons.[tc1] tc2)

and typeAEquivAux erasureFlag g aenv ty1 ty2 =

let ty1 = stripTyEqnsWrtErasure erasureFlag g ty1

let ty2 = stripTyEqnsWrtErasure erasureFlag g ty2

match ty1, ty2 with

| TType_forall(tps1,rty1), TType_forall(tps2,rty2) ->

typarsAEquivAux erasureFlag g aenv tps1 tps2 && typeAEquivAux erasureFlag g (aenv.BindEquivTypars tps1 tps2) rty1 rty2

| TType_var tp1, TType_var tp2 when typarEq tp1 tp2 ->

true

| TType_var tp1, _ when aenv.EquivTypars.ContainsKey tp1 ->

typeEquivAux erasureFlag g aenv.EquivTypars.[tp1] ty2

| TType_app (tc1,b1) ,TType_app (tc2,b2) ->

tcrefAEquiv g aenv tc1 tc2 &&

typesAEquivAux erasureFlag g aenv b1 b2

| TType_ucase (UCRef(tc1,n1),b1) ,TType_ucase (UCRef(tc2,n2),b2) ->

n1=n2 &&

tcrefAEquiv g aenv tc1 tc2 &&

typesAEquivAux erasureFlag g aenv b1 b2

| TType_tuple (s1,l1),TType_tuple (s2,l2) ->

structnessAEquiv s1 s2 && typesAEquivAux erasureFlag g aenv l1 l2

| TType_fun (dtys1,rty1),TType_fun (dtys2,rty2) ->

typeAEquivAux erasureFlag g aenv dtys1 dtys2 && typeAEquivAux erasureFlag g aenv rty1 rty2

| TType_measure m1, TType_measure m2 ->

match erasureFlag with

| EraseNone -> measureAEquiv g aenv m1 m2

| _ -> true

| _ -> false

and structnessAEquiv un1 un2 =

match un1, un2 with

| TupInfo.Const b1, TupInfo.Const b2 -> (b1 = b2)

and measureAEquiv g aenv un1 un2 =

let vars1 = ListMeasureVarOccs un1

let trans tp1 = if aenv.EquivTypars.ContainsKey tp1 then destAnyParTy g aenv.EquivTypars.[tp1] else tp1

let remapTyconRef tc = if aenv.EquivTycons.ContainsKey tc then aenv.EquivTycons.[tc] else tc

let vars1' = List.map trans vars1

let vars2 = ListSet.subtract typarEq (ListMeasureVarOccs un2) vars1'

let cons1 = ListMeasureConOccsAfterRemapping g remapTyconRef un1

let cons2 = ListMeasureConOccsAfterRemapping g remapTyconRef un2

List.forall (fun v -> MeasureVarExponent v un1 = MeasureVarExponent (trans v) un2) vars1 &&

List.forall (fun v -> MeasureVarExponent v un1 = MeasureVarExponent v un2) vars2 &&

List.forall (fun c -> MeasureConExponentAfterRemapping g remapTyconRef c un1 = MeasureConExponentAfterRemapping g remapTyconRef c un2) (cons1@cons2)

and typesAEquivAux erasureFlag g aenv l1 l2 = List.lengthsEqAndForall2 (typeAEquivAux erasureFlag g aenv) l1 l2

and typeEquivAux erasureFlag g ty1 ty2 = typeAEquivAux erasureFlag g TypeEquivEnv.Empty ty1 ty2

let typeAEquiv g aenv ty1 ty2 = typeAEquivAux EraseNone g aenv ty1 ty2

let typeEquiv g ty1 ty2 = typeEquivAux EraseNone g ty1 ty2

let traitsAEquiv g aenv t1 t2 = traitsAEquivAux EraseNone g aenv t1 t2

let typarConstraintsAEquiv g aenv c1 c2 = typarConstraintsAEquivAux EraseNone g aenv c1 c2

let typarsAEquiv g aenv d1 d2 = typarsAEquivAux EraseNone g aenv d1 d2

let returnTypesAEquiv g aenv t1 t2 = returnTypesAEquivAux EraseNone g aenv t1 t2

let measureEquiv g m1 m2 = measureAEquiv g TypeEquivEnv.Empty m1 m2

let isErasedType g ty =

match stripTyEqns g ty with

#if EXTENSIONTYPING

| TType_app (tcref,_) -> tcref.IsProvidedErasedTycon

| _ -> false

let rec getErasedTypes g ty =

let ty = stripTyEqns g ty

if isErasedType g ty then [ty] else

match ty with

| TType_forall(_,rty) ->

getErasedTypes g rty

| TType_var tp ->

if tp.IsErased then [ty] else []

| TType_app (_,b) | TType_ucase(_,b) | TType_tuple (_, b) ->

List.foldBack (fun ty tys -> getErasedTypes g ty @ tys) b []

| TType_fun (dty,rty) ->

getErasedTypes g dty @ getErasedTypes g rty

| TType_measure _ ->