csharpfftfsharpintegrationinterpolationlinear-algebramathdifferentiationmatrixnumericsrandomregressionstatisticsmathnet
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
428 lines
15 KiB
428 lines
15 KiB
// (c) Microsoft Corporation. All rights reserved
|
|
|
|
#light
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Expression and Type Specifications. These are what we save
|
|
//-------------------------------------------------------------------------
|
|
|
|
|
|
module (* internal *) Microsoft.FSharp.Compiler.Sreflect
|
|
|
|
open Internal.Utilities
|
|
open Internal.Utilities.Pervasives
|
|
open Microsoft.FSharp.Compiler.AbstractIL
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Internal
|
|
open Microsoft.FSharp.Compiler
|
|
open Microsoft.FSharp.Compiler.Lib
|
|
|
|
module Bytebuf = Bytes.Bytebuf
|
|
module Bytestream = Bytes.Bytestream
|
|
|
|
let mkRLinear mk (vs,body) = List.foldBack (fun v acc -> mk (v,acc)) vs body
|
|
|
|
type TypeVarData = { tvName: string; }
|
|
type NamedTypeData = { 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 mkNamedTy (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 }
|
|
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
|
|
| AddressSetOp
|
|
| TypeTestOp
|
|
| TryFinallyOp
|
|
| TryWithOp
|
|
|
|
|
|
/// Represents specifications of a subset of F# expressions
|
|
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
|
|
|
|
let mkVar v = VarExpr v
|
|
let mkHole (v,idx) = HoleExpr (v ,idx)
|
|
let mkApp (a,b) = CombExpr(AppOp, [], [a; b]) (* REVIEW: type arguments? *)
|
|
let mkLambda (a,b) = LambdaExpr (a,b)
|
|
let mkQuote (a) = QuoteExpr (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 in
|
|
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 mkSum ((d1,d2),tyargs,args) = CombExpr(SumMkOp(d1,d2),tyargs,args)
|
|
let mkSumFieldGet ((d1,d2,d3),tyargs,arg) = CombExpr(SumFieldGetOp(d1,d2,d3),tyargs,[arg])
|
|
let mkSumTagTest ((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 mkDefaultValue (ty) = CombExpr(DefaultValueOp,[ty],[])
|
|
let mkNewArray (ty,args) = CombExpr(NewArrayOp,[ty],args)
|
|
|
|
let mkBool v = CombExpr(BoolOp v,[],[])
|
|
let mkString v = CombExpr(StringOp v,[],[])
|
|
let mkSingle v = CombExpr(SingleOp v,[],[])
|
|
let mkDouble v = CombExpr(DoubleOp v,[],[])
|
|
let mkChar v = CombExpr(CharOp v,[],[])
|
|
let mkSByte v = CombExpr(SByteOp v,[],[])
|
|
let mkByte v = CombExpr(ByteOp v,[],[])
|
|
let mkInt16 v = CombExpr(Int16Op v,[],[])
|
|
let mkUInt16 v = CombExpr(UInt16Op v,[],[])
|
|
let mkInt32 v = CombExpr(Int32Op v,[],[])
|
|
let mkUInt32 v = CombExpr(UInt32Op v,[],[])
|
|
let mkInt64 v = CombExpr(Int64Op v,[],[])
|
|
let mkUInt64 v = CombExpr(UInt64Op v,[],[])
|
|
|
|
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])
|
|
|
|
//---------------------------------------------------------------------------
|
|
// Pickle/unpickle expression and type specifications in a stable format
|
|
// compatible with those read by Microsoft.FSharp.Quotations
|
|
//---------------------------------------------------------------------------
|
|
|
|
let pickledDefinitionsResourceNameBase = "ReflectedDefinitions"
|
|
|
|
let freshVar (n,ty) = {vText=n; vType=ty}
|
|
|
|
module SimplePickle = begin
|
|
|
|
type 'a tbl =
|
|
{ tbl: Hashtbl.t<'a,int>;
|
|
mutable rows: 'a list;
|
|
mutable count: int }
|
|
|
|
let new_tbl () =
|
|
{ tbl = (Hashtbl.create 20);
|
|
rows=[];
|
|
count=0; }
|
|
|
|
let get_tbl tbl = List.rev tbl.rows
|
|
let tbl_size tbl = List.length tbl.rows
|
|
|
|
let add_entry tbl x =
|
|
let n = tbl.count in
|
|
tbl.count <- tbl.count + 1;
|
|
Hashtbl.add tbl.tbl x n;
|
|
tbl.rows <- x :: tbl.rows;
|
|
n
|
|
|
|
let find_or_add_entry tbl x =
|
|
if Hashtbl.mem tbl.tbl x then Hashtbl.find tbl.tbl x
|
|
else add_entry tbl x
|
|
|
|
|
|
let tbl_find tbl x = Hashtbl.find tbl.tbl x
|
|
|
|
let tbl_mem tbl x = Hashtbl.mem tbl.tbl x
|
|
|
|
type outstate =
|
|
{ os: Bytebuf.t;
|
|
ostrings: string tbl }
|
|
|
|
let p_byte b st = Bytebuf.emit_int_as_byte st.os b
|
|
let p_bool b st = p_byte (if b then 1 else 0) st
|
|
let p_void (os: outstate) = ()
|
|
let p_unit () (os: outstate) = ()
|
|
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 st =
|
|
let len = Bytes.length s
|
|
p_int32 (len) st;
|
|
Bytebuf.emit_bytes st.os s
|
|
|
|
let prim_pstring s st =
|
|
let bytes = Bytes.string_as_utf8_bytes s
|
|
let len = Bytes.length bytes
|
|
p_int32 (len) st;
|
|
Bytebuf.emit_bytes st.os 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:outstate) = (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 key st = p_int (find_or_add_entry tbl 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 = Bytebuf.create 100000;
|
|
ostrings=new_tbl(); } in
|
|
p x st1;
|
|
get_tbl st1.ostrings, Bytebuf.close st1.os in
|
|
let phase2data = (stringTab,phase1bytes) in
|
|
let phase2bytes =
|
|
let st2 =
|
|
{ os = Bytebuf.create 100000;
|
|
ostrings=new_tbl();} in
|
|
p_tup2 (p_list prim_pstring) p_bytes phase2data st2;
|
|
Bytebuf.close st2.os in
|
|
phase2bytes
|
|
end
|
|
|
|
open SimplePickle
|
|
|
|
|
|
let p_assref x st = p_string x st
|
|
|
|
let p_NamedType x st = p_tup2 p_string p_assref (x.tcName, x.tcAssembly) 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_tup2 p_string p_type (v.vText,v.vType) 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
|
|
|
|
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
|
|
|
|
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 pdmkns defs = p_list (p_tup2 p_MethodBase p_expr) defs
|
|
let PickleDefns = pickle_obj pdmkns
|
|
|
|
|
|
|