open System.Text

open Internal.Utilities.Collections

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler

open Microsoft.FSharp.Compiler.Lib

let mkRLinear mk (vs,body) = List.foldBack (fun v acc -> mk (v,acc)) vs body

type TypeVarData = { tvName: string; }

type NamedTypeData =

| Idx of int

| Named of (* tcName: *) string * (* tcAssembly: *) string

type TypeCombOp =

| ArrayTyOp of int (* rank *)

| FunTyOp

| NamedTyOp of NamedTypeData

type TypeData =

| VarType of int

| AppType of TypeCombOp * TypeData list

let mkVarTy v = VarType v

let mkFunTy (x1,x2) = AppType(FunTyOp, [x1; x2])

let mkArrayTy (n,x) = AppType(ArrayTyOp n, [x])

let mkILNamedTy (r,l) = AppType(NamedTyOp r,l)

type CtorData =

{ ctorParent: NamedTypeData;

ctorArgTypes: TypeData list; }

type MethodData =

{ methParent: NamedTypeData;

methName: string;

methArgTypes: TypeData list;

methRetType: TypeData;

numGenericArgs: int }

type VarData =

{ vText: string;

vType: TypeData;

vMutable: bool }

type FieldData = NamedTypeData * string

type RecdFieldData = NamedTypeData * string

type PropInfoData = NamedTypeData * string * TypeData * TypeData list

type CombOp =

| AppOp

| CondOp

| ModuleValueOp of NamedTypeData * string * bool

| LetRecOp

| LetRecCombOp

| LetOp

| RecdMkOp of NamedTypeData

| RecdGetOp of NamedTypeData * string

| RecdSetOp of NamedTypeData * string

| SumMkOp of NamedTypeData * string

| SumFieldGetOp of NamedTypeData * string * int

| SumTagTestOp of NamedTypeData * string

| TupleMkOp

| TupleGetOp of int

| UnitOp

| BoolOp of bool

| StringOp of string

| SingleOp of float32

| DoubleOp of float

| CharOp of char

| SByteOp of sbyte

| ByteOp of byte

| Int16Op of int16

| UInt16Op of uint16

| Int32Op of int32

| UInt32Op of uint32

| Int64Op of int64

| UInt64Op of uint64

| PropGetOp of PropInfoData

| FieldGetOp of NamedTypeData * string

| CtorCallOp of CtorData

| MethodCallOp of MethodData

| CoerceOp

| NewArrayOp

| DelegateOp

| SeqOp

| ForLoopOp

| WhileLoopOp

| NullOp

| DefaultValueOp

| PropSetOp of PropInfoData

| FieldSetOp of NamedTypeData * string

| AddressOfOp

| ExprSetOp

| AddressSetOp

| TypeTestOp

| TryFinallyOp

| TryWithOp

type ExprData =

| AttrExpr of ExprData * ExprData list

| CombExpr of CombOp * TypeData list * ExprData list

| VarExpr of int

| QuoteExpr of ExprData

| LambdaExpr of VarData * ExprData

| HoleExpr of TypeData * int

| ThisVarExpr of TypeData

| QuoteRawExpr of ExprData

let mkVar v = VarExpr v

let mkHole (v,idx) = HoleExpr (v ,idx)

let mkApp (a,b) = CombExpr(AppOp, [], [a; b])

let mkLambda (a,b) = LambdaExpr (a,b)

let mkQuote (a) = QuoteExpr (a)

let mkQuoteRaw40 (a) = QuoteRawExpr (a)

let mkCond (x1,x2,x3) = CombExpr(CondOp,[], [x1;x2;x3])

let mkModuleValueApp (tcref,nm,isProp,tyargs,args: ExprData list list) = CombExpr(ModuleValueOp(tcref,nm,isProp),tyargs,List.concat args)

let mkTuple (ty,x) = CombExpr(TupleMkOp,[ty],x)

let mkLet ((v,e),b) = CombExpr(LetOp,[],[e;mkLambda (v,b)]) (* nb. order preserves source order *)

let mkUnit () = CombExpr(UnitOp, [], [])

let mkNull ty = CombExpr(NullOp, [ty], [])

let mkLetRecRaw e1 = CombExpr(LetRecOp,[],[e1])

let mkLetRecCombRaw args = CombExpr(LetRecCombOp,[], args)

let mkLetRec (ves,body) =

let vs,es = List.unzip ves

mkLetRecRaw(mkRLinear mkLambda (vs, mkLetRecCombRaw (body::es)))

let mkRecdMk (n,tys,args) = CombExpr(RecdMkOp n,tys,args)

let mkRecdGet ((d1,d2),tyargs,args) = CombExpr(RecdGetOp(d1,d2),tyargs,args)

let mkRecdSet ((d1,d2),tyargs,args) = CombExpr(RecdSetOp(d1,d2),tyargs,args)

let mkUnion ((d1,d2),tyargs,args) = CombExpr(SumMkOp(d1,d2),tyargs,args)

let mkUnionFieldGet ((d1,d2,d3),tyargs,arg) = CombExpr(SumFieldGetOp(d1,d2,d3),tyargs,[arg])

let mkUnionCaseTagTest ((d1,d2),tyargs,arg) = CombExpr(SumTagTestOp(d1,d2),tyargs,[arg])

let mkTupleGet (ty,n,e) = CombExpr(TupleGetOp n,[ty],[e])

let mkCoerce (ty,arg) = CombExpr(CoerceOp,[ty],[arg])

let mkTypeTest (ty,arg) = CombExpr(TypeTestOp,[ty],[arg])

let mkAddressOf (arg) = CombExpr(AddressOfOp,[],[arg])

let mkAddressSet (arg1,arg2) = CombExpr(AddressSetOp,[],[arg1;arg2])

let mkVarSet (arg1,arg2) = CombExpr(ExprSetOp,[],[arg1;arg2])

let mkDefaultValue (ty) = CombExpr(DefaultValueOp,[ty],[])

let mkThisVar (ty) = ThisVarExpr(ty)

let mkNewArray (ty,args) = CombExpr(NewArrayOp,[ty],args)

let mkBool (v, ty) = CombExpr(BoolOp v,[ty],[])

let mkString (v, ty) = CombExpr(StringOp v,[ty],[])

let mkSingle (v, ty) = CombExpr(SingleOp v,[ty],[])

let mkDouble (v, ty) = CombExpr(DoubleOp v,[ty],[])

let mkChar (v, ty) = CombExpr(CharOp v,[ty],[])

let mkSByte (v, ty) = CombExpr(SByteOp v,[ty],[])

let mkByte (v, ty) = CombExpr(ByteOp v,[ty],[])

let mkInt16 (v, ty) = CombExpr(Int16Op v,[ty],[])

let mkUInt16 (v, ty) = CombExpr(UInt16Op v,[ty],[])

let mkInt32 (v, ty) = CombExpr(Int32Op v,[ty],[])

let mkUInt32 (v, ty) = CombExpr(UInt32Op v,[ty],[])

let mkInt64 (v, ty) = CombExpr(Int64Op v,[ty],[])

let mkUInt64 (v, ty) = CombExpr(UInt64Op v,[ty],[])

let mkSequential (e1,e2) = CombExpr(SeqOp,[],[e1;e2])

let mkForLoop (x1,x2,x3) = CombExpr(ForLoopOp,[], [x1;x2;x3])

let mkWhileLoop (e1,e2) = CombExpr(WhileLoopOp,[],[e1;e2])

let mkTryFinally(e1,e2) = CombExpr(TryFinallyOp,[],[e1;e2])

let mkTryWith(e1,vf,ef,vh,eh) = CombExpr(TryWithOp,[],[e1;mkLambda(vf,ef);mkLambda(vh,eh)])

let mkDelegate (ty,e) = CombExpr(DelegateOp,[ty],[e])

let mkPropGet (d,tyargs,args) = CombExpr(PropGetOp(d),tyargs,args)

let mkPropSet (d,tyargs,args) = CombExpr(PropSetOp(d),tyargs,args)

let mkFieldGet ((d1,d2),tyargs,args) = CombExpr(FieldGetOp(d1,d2),tyargs,args)

let mkFieldSet ((d1,d2),tyargs,args) = CombExpr(FieldSetOp(d1,d2),tyargs,args)

let mkCtorCall (d,tyargs,args) = CombExpr(CtorCallOp(d),tyargs,args)

let mkMethodCall (d,tyargs,args) = CombExpr(MethodCallOp(d),tyargs,args)

let mkAttributedExpression(e,attr) = AttrExpr(e,[attr])

let isAttributedExpression e = match e with AttrExpr(_, _) -> true | _ -> false

let SerializedReflectedDefinitionsResourceNameBase = "ReflectedDefinitions"

let freshVar (n, ty, mut) = { vText=n; vType=ty; vMutable=mut }

module SimplePickle =

type Table<'T> =

{ tbl: HashMultiMap<'T,int>; // This should be "Dictionary"

mutable rows: 'T list;

mutable count: int }

static member Create () =

{ tbl = HashMultiMap(20, HashIdentity.Structural)

rows=[];

count=0; }

member tbl.AsList = List.rev tbl.rows

member tbl.Count = tbl.rows.Length

member tbl.Add x =

let n = tbl.count

tbl.count <- tbl.count + 1;

tbl.tbl.Add(x,n)

tbl.rows <- x :: tbl.rows;

n

member tbl.FindOrAdd x =

if tbl.tbl.ContainsKey x then tbl.tbl.[x]

else tbl.Add x

member tbl.Find x = tbl.tbl.[x]

member tbl.ContainsKey x = tbl.tbl.ContainsKey x

type QuotationPickleOutState =

{ os: ByteBuffer;

ostrings: Table<string> }

let p_byte b st = st.os.EmitIntAsByte b

let p_bool b st = p_byte (if b then 1 else 0) st

let p_void (_os: QuotationPickleOutState) = ()

let p_unit () (_os: QuotationPickleOutState) = ()

let prim_pint32 i st =

p_byte (Bits.b0 i) st;

p_byte (Bits.b1 i) st;

p_byte (Bits.b2 i) st;

p_byte (Bits.b3 i) st

// compress integers according to the same scheme used by CLR metadata

// This halves the size of pickled data

let p_int32 n st =

if n >= 0 && n <= 0x7F then

p_byte (Bits.b0 n) st

else if n >= 0x80 && n <= 0x3FFF then

p_byte (0x80 ||| (n >>> 8)) st;

p_byte (n &&& 0xFF) st

else

p_byte 0xFF st;

prim_pint32 n st

let p_bytes (s:byte[]) st =

let len = s.Length

p_int32 (len) st;

st.os.EmitBytes s

let prim_pstring (s:string) st =

let bytes = Encoding.UTF8.GetBytes s

let len = bytes.Length

p_int32 (len) st;

st.os.EmitBytes bytes

let p_int (c:int) st = p_int32 c st

let p_int8 (i:int8) st = p_int32 (int32 i) st

let p_uint8 (i:uint8) st = p_byte (int i) st

let p_int16 (i:int16) st = p_int32 (int32 i) st

let p_uint16 (x:uint16) st = p_int32 (int32 x) st

let puint32 (x:uint32) st = p_int32 (int32 x) st

let p_int64 i st =

p_int32 (int32 (i &&& 0xFFFFFFFFL)) st;

p_int32 (int32 (i >>> 32)) st

let bits_of_float32 (x:float32) = System.BitConverter.ToInt32(System.BitConverter.GetBytes(x),0)

let bits_of_float (x:float) = System.BitConverter.ToInt64(System.BitConverter.GetBytes(x),0)

let p_uint64 x st = p_int64 (int64 x) st

let p_double i st = p_int64 (bits_of_float i) st

let p_single i st = p_int32 (bits_of_float32 i) st

let p_char i st = p_uint16 (uint16 (int32 i)) st

let inline p_tup2 p1 p2 (a,b) (st:QuotationPickleOutState) = (p1 a st : unit); (p2 b st : unit)

let inline p_tup3 p1 p2 p3 (a,b,c) st = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit)

let inline p_tup4 p1 p2 p3 p4 (a,b,c,d) st = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit); (p4 d st : unit)

let inline p_tup5 p1 p2 p3 p4 p5 (a,b,c,d,e) st = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit); (p4 d st : unit); (p5 e st : unit)

let puniq (tbl: Table<_>) key st = p_int (tbl.FindOrAdd key) st

let p_string s st = puniq st.ostrings s st

let rec p_list f x st =

match x with

| [] -> p_byte 0 st

| h :: t -> p_byte 1 st; f h st; p_list f t st

let pickle_obj p x =

let stringTab,phase1bytes =

let st1 =

{ os = ByteBuffer.Create 100000;

ostrings=Table<_>.Create(); }

p x st1;

st1.ostrings.AsList, st1.os.Close()

let phase2data = (stringTab,phase1bytes)

let phase2bytes =

let st2 =

{ os = ByteBuffer.Create 100000;

ostrings=Table<_>.Create();}

p_tup2 (p_list prim_pstring) p_bytes phase2data st2;

st2.os.Close()

phase2bytes

open SimplePickle

let p_assref x st = p_string x st

let p_NamedType x st =

match x with

| Idx n -> p_tup2 p_string p_assref (string n, "") st

| Named (nm,ass) -> p_tup2 p_string p_assref (nm, ass) st

let p_tycon x st =

match x with

| FunTyOp -> p_byte 1 st

| NamedTyOp a -> p_byte 2 st; p_NamedType a st

| ArrayTyOp a -> p_byte 3 st; p_int a st

let rec p_type x st =

match x with

| VarType v -> p_byte 0 st; p_int v st

| AppType(c,ts) -> p_byte 1 st; p_tup2 p_tycon p_types (c,ts) st

and p_types x st = p_list p_type x st

let p_varDecl v st = p_tup3 p_string p_type p_bool (v.vText, v.vType, v.vMutable) st

let p_recdFieldSpec v st = p_tup2 p_NamedType p_string v st

let p_ucaseSpec v st = p_tup2 p_NamedType p_string v st

let p_MethodData a st =

p_tup5 p_NamedType p_types p_type p_string p_int (a.methParent,a.methArgTypes,a.methRetType, a.methName, a.numGenericArgs) st

let p_CtorData a st =

p_tup2 p_NamedType p_types (a.ctorParent,a.ctorArgTypes) st

let p_PropInfoData a st =

p_tup4 p_NamedType p_string p_type p_types a st

let p_CombOp x st =

match x with

| CondOp -> p_byte 0 st

| ModuleValueOp (x,y,z) -> p_byte 1 st; p_tup3 p_NamedType p_string p_bool (x,y,z) st

| LetRecOp -> p_byte 2 st

| RecdMkOp a -> p_byte 3 st; p_NamedType a st

| RecdGetOp (x,y) -> p_byte 4 st; p_recdFieldSpec (x,y) st

| SumMkOp (x,y) -> p_byte 5 st; p_ucaseSpec (x,y) st

| SumFieldGetOp (a,b,c) -> p_byte 6 st; p_tup2 p_ucaseSpec p_int ((a,b),c) st

| SumTagTestOp (x,y) -> p_byte 7 st; p_ucaseSpec (x,y) st

| TupleMkOp -> p_byte 8 st

| TupleGetOp a -> p_byte 9 st; p_int a st

| BoolOp a -> p_byte 11 st; p_bool a st

| StringOp a -> p_byte 12 st; p_string a st

| SingleOp a -> p_byte 13 st; p_single a st

| DoubleOp a -> p_byte 14 st; p_double a st

| CharOp a -> p_byte 15 st; p_char a st

| SByteOp a -> p_byte 16 st; p_int8 a st

| ByteOp a -> p_byte 17 st; p_uint8 a st

| Int16Op a -> p_byte 18 st; p_int16 a st

| UInt16Op a -> p_byte 19 st; p_uint16 a st

| Int32Op a -> p_byte 20 st; p_int32 a st

| UInt32Op a -> p_byte 21 st; puint32 a st

| Int64Op a -> p_byte 22 st; p_int64 a st

| UInt64Op a -> p_byte 23 st; p_uint64 a st

| UnitOp -> p_byte 24 st

| PropGetOp d -> p_byte 25 st; p_PropInfoData d st

| CtorCallOp a -> p_byte 26 st; p_CtorData a st

| CoerceOp -> p_byte 28 st

| SeqOp -> p_byte 29 st

| ForLoopOp -> p_byte 30 st

| MethodCallOp a -> p_byte 31 st; p_MethodData a st

| NewArrayOp -> p_byte 32 st

| DelegateOp -> p_byte 33 st

| WhileLoopOp -> p_byte 34 st

| LetOp -> p_byte 35 st

| RecdSetOp (x,y) -> p_byte 36 st; p_recdFieldSpec (x,y) st

| FieldGetOp (a,b) -> p_byte 37 st; p_tup2 p_NamedType p_string (a, b) st

| LetRecCombOp -> p_byte 38 st

| AppOp -> p_byte 39 st

| NullOp -> p_byte 40 st

| DefaultValueOp -> p_byte 41 st

| PropSetOp d -> p_byte 42 st; p_PropInfoData d st

| FieldSetOp (a,b) -> p_byte 43 st; p_tup2 p_NamedType p_string (a, b) st

| AddressOfOp -> p_byte 44 st

| AddressSetOp -> p_byte 45 st

| TypeTestOp -> p_byte 46 st

| TryFinallyOp -> p_byte 47 st

| TryWithOp -> p_byte 48 st

| ExprSetOp -> p_byte 49 st

let rec p_expr x st =

match x with

| CombExpr(c,ts,args) -> p_byte 0 st; p_tup3 p_CombOp p_types (p_list p_expr) (c,ts,args) st

| VarExpr v -> p_byte 1 st; p_int v st

| LambdaExpr(v,e) -> p_byte 2 st; p_tup2 p_varDecl p_expr (v,e) st

| HoleExpr(ty,idx) -> p_byte 3 st; p_type ty st; p_int idx st

| QuoteExpr(tm) -> p_byte 4 st; p_expr tm st

| AttrExpr(e,attrs) -> p_byte 5 st; p_tup2 p_expr (p_list p_expr) (e,attrs) st

| ThisVarExpr(ty) -> p_byte 6 st; p_type ty st

| QuoteRawExpr(tm) -> p_byte 7 st; p_expr tm st

type ModuleDefnData =

{ Module: NamedTypeData;

Name: string;

IsProperty: bool }

type MethodBaseData =

| ModuleDefn of ModuleDefnData

| Method of MethodData

| Ctor of CtorData

let pickle = pickle_obj p_expr

let p_MethodBase x st =

match x with

| ModuleDefn md ->

p_byte 0 st;

p_NamedType md.Module st;

p_string md.Name st;

p_bool md.IsProperty st

| Method md ->

p_byte 1 st;

p_MethodData md st

| Ctor md ->

p_byte 2 st;

p_CtorData md st

let PickleDefns = pickle_obj (p_list (p_tup2 p_MethodBase p_expr))