Math.NET Numerics
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.
 
 
 

458 lines
19 KiB

// (c) Microsoft Corporation. All rights reserved
module (* internal *) Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiConstants
open Internal.Utilities
open Microsoft.FSharp.Compiler.AbstractIL
open Microsoft.FSharp.Compiler.AbstractIL.Internal
module Ildiag = Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
module Ilx = Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types
module Il = Microsoft.FSharp.Compiler.AbstractIL.IL
open Ildiag
open Il
open Ilx
(* The hasthis i.e. static/nonstatic part of the calling convention *)
(* participates in binding, i.e. constructors have the flag set. *)
(* However, when quoting a constructor at the callsite of a newobj *)
(* instruction the flag does not have to be given, even though that *)
(* results in an inadequate specification of the method to call. *)
(* Thus we perform a fix-up on every method quoted at a newobj instruction, *)
(* forcing the flag to be set. This is only for naming/linking purposes, *)
(* and the semantic meaning of the flag, as stored in the method callsig, is *)
(* not effected. *)
let set_hasthis_in_callconv hasthis (Callconv (_,bcc)) = Callconv (hasthis,bcc)
let set_hasthis_in_callsig hasthis x = {x with callsigCallconv= set_hasthis_in_callconv hasthis x.callsigCallconv}
let set_hasthis_in_mref hasthis (x:ILMethodRef) =
ILMethodRef.Create(enclosingTypeRef=x.EnclosingTypeRef,
callingConv=set_hasthis_in_callconv hasthis x.CallingConv,
name=x.Name,
genericArity=x.GenericArity,
argTypes= x.ArgTypes,
returnType= x.ReturnType)
let set_hasthis_in_mspec hasthis x = let x1,x2,x3 = dest_mspec x in mk_mref_mspec_in_typ(set_hasthis_in_mref hasthis x1,x2,x3)
let pretty () = true
let parse_ilGlobals = ref (ecmaILGlobals)
(* --------------------------------------------------------------------
* Table of parsing and pretty printing data for instructions.
* - PP data is only used for instructions with no arguments
* -------------------------------------------------------------------- *)
let noarg_instrs =
lazy [
["ldc";"i4";"0"], (((mk_ldc_i32 (0))));
["ldc";"i4";"1"], (((mk_ldc_i32 (1))));
["ldc";"i4";"2"], (((mk_ldc_i32 (2))));
["ldc";"i4";"3"], (((mk_ldc_i32 (3))));
["ldc";"i4";"4"], (((mk_ldc_i32 (4))));
["ldc";"i4";"5"], (((mk_ldc_i32 (5))));
["ldc";"i4";"6"], (((mk_ldc_i32 (6))));
["ldc";"i4";"7"], (((mk_ldc_i32 (7))));
["ldc";"i4";"8"], (((mk_ldc_i32 (8))));
["ldc";"i4";"M1"], (((mk_ldc_i32 ((0-1)))));
["ldc";"i4";"m1"], (((mk_ldc_i32 ((0-1)))));
["stloc";"0"], (I_stloc (uint16 ( 0)));
["stloc";"1"], (I_stloc (uint16 ( 1)));
["stloc";"2"], (I_stloc (uint16 ( 2)));
["stloc";"3"], (I_stloc (uint16 ( 3)));
["ldloc";"0"], (I_ldloc (uint16 ( 0)));
["ldloc";"1"], (I_ldloc (uint16 ( 1)));
["ldloc";"2"], (I_ldloc (uint16 ( 2)));
["ldloc";"3"], (I_ldloc (uint16 ( 3)));
["ldarg";"0"], (I_ldarg (uint16 ( 0)));
["ldarg";"1"], (I_ldarg (uint16 ( 1)));
["ldarg";"2"], (I_ldarg (uint16 ( 2)));
["ldarg";"3"], (I_ldarg (uint16 ( 3)));
["ret"], (I_ret);
["add"], (I_arith AI_add);
["add";"ovf"], (I_arith AI_add_ovf);
["add";"ovf";"un"], (I_arith AI_add_ovf_un);
["and"], (I_arith AI_and);
["div"], (I_arith AI_div);
["div";"un"], (I_arith AI_div_un);
["ceq"], (I_arith AI_ceq);
["cgt"], (I_arith AI_cgt );
["cgt";"un"], (I_arith AI_cgt_un);
["clt"], (I_arith AI_clt);
["clt";"un"], (I_arith AI_clt_un);
["conv";"i1"], (I_arith (AI_conv DT_I1));
["conv";"i2"], (I_arith (AI_conv DT_I2));
["conv";"i4"], (I_arith (AI_conv DT_I4));
["conv";"i8"], (I_arith (AI_conv DT_I8));
["conv";"i"], (I_arith (AI_conv DT_I));
["conv";"r4"], (I_arith (AI_conv DT_R4));
["conv";"r8"], (I_arith (AI_conv DT_R8));
["conv";"u1"], (I_arith (AI_conv DT_U1));
["conv";"u2"], (I_arith (AI_conv DT_U2));
["conv";"u4"], (I_arith (AI_conv DT_U4));
["conv";"u8"], (I_arith (AI_conv DT_U8));
["conv";"u"], (I_arith (AI_conv DT_U));
["conv";"r"; "un"], (I_arith (AI_conv DT_R));
["conv";"ovf";"i1"], (I_arith (AI_conv_ovf DT_I1));
["conv";"ovf";"i2"], (I_arith (AI_conv_ovf DT_I2));
["conv";"ovf";"i4"], (I_arith (AI_conv_ovf DT_I4));
["conv";"ovf";"i8"], (I_arith (AI_conv_ovf DT_I8));
["conv";"ovf";"i"], (I_arith (AI_conv_ovf DT_I));
["conv";"ovf";"u1"], (I_arith (AI_conv_ovf DT_U1));
["conv";"ovf";"u2"], (I_arith (AI_conv_ovf DT_U2));
["conv";"ovf";"u4"], (I_arith (AI_conv_ovf DT_U4));
["conv";"ovf";"u8"], (I_arith (AI_conv_ovf DT_U8));
["conv";"ovf";"u"], (I_arith (AI_conv_ovf DT_U));
["conv";"ovf";"i1"; "un"], (I_arith (AI_conv_ovf_un DT_I1));
["conv";"ovf";"i2"; "un"], (I_arith (AI_conv_ovf_un DT_I2));
["conv";"ovf";"i4"; "un"], (I_arith (AI_conv_ovf_un DT_I4));
["conv";"ovf";"i8"; "un"], (I_arith (AI_conv_ovf_un DT_I8));
["conv";"ovf";"i"; "un"], (I_arith (AI_conv_ovf_un DT_I));
["conv";"ovf";"u1"; "un"], (I_arith (AI_conv_ovf_un DT_U1));
["conv";"ovf";"u2"; "un"], (I_arith (AI_conv_ovf_un DT_U2));
["conv";"ovf";"u4"; "un"], (I_arith (AI_conv_ovf_un DT_U4));
["conv";"ovf";"u8"; "un"], (I_arith (AI_conv_ovf_un DT_U8));
["conv";"ovf";"u"; "un"], (I_arith (AI_conv_ovf_un DT_U));
["stelem";"i1"], (I_stelem DT_I1);
["stelem";"i2"], (I_stelem DT_I2);
["stelem";"i4"], (I_stelem DT_I4);
["stelem";"i8"], (I_stelem DT_I8);
["stelem";"r4"], (I_stelem DT_R4);
["stelem";"r8"], (I_stelem DT_R8);
["stelem";"i"], (I_stelem DT_I);
["stelem";"u"], (I_stelem DT_I);
["stelem";"u8"], (I_stelem DT_I8);
["stelem";"ref"], (I_stelem DT_REF);
["ldelem";"i1"], (I_ldelem DT_I1);
["ldelem";"i2"], (I_ldelem DT_I2);
["ldelem";"i4"], (I_ldelem DT_I4);
["ldelem";"i8"], (I_ldelem DT_I8);
["ldelem";"u8"], (I_ldelem DT_I8);
["ldelem";"u1"], (I_ldelem DT_U1);
["ldelem";"u2"], (I_ldelem DT_U2);
["ldelem";"u4"], (I_ldelem DT_U4);
["ldelem";"r4"], (I_ldelem DT_R4);
["ldelem";"r8"], (I_ldelem DT_R8);
["ldelem";"u"], (I_ldelem DT_I); (* EQUIV *)
["ldelem";"i"], (I_ldelem DT_I);
["ldelem";"ref"], (I_ldelem DT_REF);
["mul"], (I_arith AI_mul );
["mul";"ovf"], (I_arith AI_mul_ovf);
["mul";"ovf";"un"], (I_arith AI_mul_ovf_un);
["rem"], (I_arith AI_rem );
["rem";"un"], (I_arith AI_rem_un );
["shl"], (I_arith AI_shl );
["shr"], (I_arith AI_shr );
["shr";"un"], (I_arith AI_shr_un);
["sub"], (I_arith AI_sub );
["sub";"ovf"], (I_arith AI_sub_ovf);
["sub";"ovf";"un"], (I_arith AI_sub_ovf_un);
["xor"], (I_arith AI_xor);
["or"], (I_arith AI_or);
["neg"], (I_arith AI_neg);
["not"], (I_arith AI_not);
["ldnull"], (I_arith AI_ldnull);
["dup"], (I_arith AI_dup);
["pop"], (I_arith AI_pop);
["ckfinite"], (I_arith AI_ckfinite);
["nop"], (I_arith AI_nop);
["break"], (I_break);
["arglist"], (I_arglist);
["endfilter"], (I_endfilter);
["endfinally"], I_endfinally;
["refanytype"], (I_refanytype);
["localloc"], (I_localloc);
["throw"], (I_throw);
["ldlen"], (I_ldlen);
["rethrow"], (I_rethrow);
];;
let words_of_noarg_instr, is_noarg_instr =
let t =
lazy begin
let t = Hashtbl.create 300 in
List.iter (fun (x,mk) -> Hashtbl.add t mk x) (Lazy.force noarg_instrs);
t
end in
(fun s -> Hashtbl.find (Lazy.force t) s),
(fun s -> Hashtbl.mem (Lazy.force t) s)
(* --------------------------------------------------------------------
* Instructions are preceded by prefixes, e.g. ".tail" etc.
* -------------------------------------------------------------------- *)
type instr_name = string list
type 'a named = instr_name * 'a
type prefix =
| Prefix_Tail
| Prefix_Volatile
| Prefix_Unaligned of int
| Prefix_Readonly
| Prefix_Constrained of ILType
type prefixes = prefix list
let prefix_processor nm mk = (nm, fun x (prefixes:prefixes) -> mk prefixes x)
let no_prefixes (nm,mk) =
prefix_processor nm
(function
[] -> mk
| h::t -> failwith ("no prefixes are not allowed for instruction"^String.concat "." nm))
let int_to_unaligned n =
if n = 1 then Unaligned_1
else if n = 2 then Unaligned_2
else if n = 4 then Unaligned_4
else failwith "int_to_unaligned"
let volatile_unaligned_prefix (nm,mk) =
prefix_processor nm
(function
[] -> mk(Aligned, Nonvolatile)
| [Prefix_Unaligned n] -> mk(int_to_unaligned n, Nonvolatile)
| [Prefix_Volatile] -> mk(Aligned, Volatile)
| [Prefix_Unaligned n;Prefix_Volatile]
| [Prefix_Volatile;Prefix_Unaligned n] -> mk(int_to_unaligned n, Volatile)
| _ -> failwith ("bad prefix for instruction"^String.concat "." nm))
let volatile_prefix (nm,mk) =
prefix_processor nm
(function
[] -> mk(Nonvolatile)
| [Prefix_Volatile] -> mk(Volatile)
| _ -> failwith ("bad prefix for instruction"^String.concat "." nm))
let tail_prefix (nm,mk) =
prefix_processor nm
(function
[] -> mk Normalcall
| [Prefix_Tail] -> mk Tailcall
| _ -> failwith ("bad prefix for instruction"^String.concat "." nm))
let readonly_prefix (nm,mk) =
prefix_processor nm
(function
[] -> mk NormalAddress
| [Prefix_Readonly] -> mk ReadonlyAddress
| _ -> failwith ("bad prefix for instruction"^String.concat "." nm))
let constraint_tail_prefix (nm,mk) =
prefix_processor nm
(function
[] -> mk (None, Normalcall)
| [Prefix_Tail] -> mk (None,Tailcall)
| [Prefix_Constrained ty; Prefix_Tail]
| [ Prefix_Tail; Prefix_Constrained ty] -> mk (Some ty,Tailcall)
| [ Prefix_Constrained ty] -> mk (Some ty,Normalcall)
| _ -> failwith ("bad prefix for instruction"^String.concat "." nm))
let mk_stind (nm,dt) = volatile_unaligned_prefix (nm, (fun (x,y) () -> I_stind(x,y,dt)))
let mk_ldind (nm,dt) = volatile_unaligned_prefix (nm, (fun (x,y) () -> I_ldind(x,y,dt)))
(* --------------------------------------------------------------------
* Parsing only... Tables of different types of instructions.
* First the different kinds of instructions.
* -------------------------------------------------------------------- *)
type CoreInstr = prefixes -> ILInstr
type none_instr = (unit -> CoreInstr)
type i32_instr = (int32 -> CoreInstr)
type i32_i32_instr = (int32 * int32 -> CoreInstr)
type arg_instr = (uint16 -> CoreInstr)
type env_instr = (int -> CoreInstr)
type loc_instr = (uint16 -> CoreInstr)
type arg_typ_instr = (uint16 * ILType -> CoreInstr)
type i64_instr = (int64 -> CoreInstr)
type real_instr = (ILConstSpec -> CoreInstr)
//type field_instr = (ILFieldSpec -> CoreInstr)
type method_instr = (ILMethodSpec * varargs -> CoreInstr)
type unconditional_instr = (ILCodeLabel -> CoreInstr)
type conditional_instr = (ILCodeLabel * ILCodeLabel -> CoreInstr)
type type_instr = (ILType -> CoreInstr)
type int_type_instr = (int * ILType -> CoreInstr)
type valuetype_instr = (ILType -> CoreInstr) (* nb. diff. interp of types to type_instr *)
type string_instr = (string -> CoreInstr)
//type sig_instr = (ILCallingSignature * varargs -> CoreInstr)
type tok_instr = (ILTokenSpec -> CoreInstr)
type switch_instr = (ILCodeLabel list * ILCodeLabel -> CoreInstr)
(* --------------------------------------------------------------------
* Now the generic code to make a table of instructions
* -------------------------------------------------------------------- *)
type 'a instr_table = (string list * 'a) list
type 'a lazy_instr_table = 'a instr_table Lazy.t
let mk_table l = l
(* let tab = Hashtbl.create 100 in
List.iter (fun (x,mk) -> Hashtbl.add tab x mk) l;
(tab : 'a instr_table);;
*)
(* --------------------------------------------------------------------
* Now the tables of instructions
* -------------------------------------------------------------------- *)
let arg_instrs =
lazy (mk_table [
no_prefixes (["ldarg"], (fun x -> I_ldarg x));
no_prefixes (["ldarg";"s"], (fun x -> I_ldarg x));
no_prefixes (["starg"], (fun x -> I_starg x));
no_prefixes (["starg";"s"], (fun x -> I_starg x));
no_prefixes (["ldarga"], (fun x -> I_ldarga x));
no_prefixes (["ldarga";"s"], (fun x -> I_ldarga x));
] : arg_instr instr_table)
let loc_instrs =
lazy (mk_table [
no_prefixes (["stloc"], (fun x -> I_stloc x));
no_prefixes (["stloc";"s"], (fun x -> I_stloc x));
no_prefixes (["ldloc"], (fun x -> I_ldloc x));
no_prefixes (["ldloc";"s"], (fun x -> I_ldloc x));
no_prefixes (["ldloca"], (fun x -> I_ldloca x));
no_prefixes (["ldloca";"s"], (fun x -> I_ldloca x));
] : loc_instr instr_table)
let none_instrs =
lazy (mk_table
(List.map (fun (nm,i) -> no_prefixes (nm,(fun () -> i))) (Lazy.force noarg_instrs) @
[ (mk_stind (["stind";"u"], DT_I));
(mk_stind (["stind";"i"], DT_I));
(mk_stind (["stind";"u1"], DT_I1));(* ILX EQUIVALENT *)
(mk_stind (["stind";"i1"], DT_I1));
(mk_stind (["stind";"u2"], DT_I2));
(mk_stind (["stind";"i2"], DT_I2));
(mk_stind (["stind";"u4"], DT_I4)); (* ILX EQUIVALENT *)
(mk_stind (["stind";"i4"], DT_I4));
(mk_stind (["stind";"u8"], DT_I8)); (* ILX EQUIVALENT *)
(mk_stind (["stind";"i8"], DT_I8));
(mk_stind (["stind";"r4"], DT_R4));
(mk_stind (["stind";"r8"], DT_R8));
(mk_stind (["stind";"ref"], DT_REF));
(mk_ldind (["ldind";"i"], DT_I));
(mk_ldind (["ldind";"i1"], DT_I1));
(mk_ldind (["ldind";"i2"], DT_I2));
(mk_ldind (["ldind";"i4"], DT_I4));
(mk_ldind (["ldind";"i8"], DT_I8));
(mk_ldind (["ldind";"u1"], DT_U1));
(mk_ldind (["ldind";"u2"], DT_U2));
(mk_ldind (["ldind";"u4"], DT_U4));
(mk_ldind (["ldind";"u8"], DT_I8));
(mk_ldind (["ldind";"r4"], DT_R4));
(mk_ldind (["ldind";"r8"], DT_R8));
(mk_ldind (["ldind";"ref"], DT_REF));
volatile_unaligned_prefix (["cpblk"], (fun (x,y) () -> I_cpblk(x,y)));
volatile_unaligned_prefix (["initblk"], (fun (x,y) () -> I_initblk(x,y)));
]) : none_instr instr_table);;
let i64_instrs =
lazy (mk_table [
no_prefixes (["ldc";"i8"], (fun x ->I_arith (AI_ldc (DT_I8, NUM_I8 x))));
] : i64_instr instr_table)
let i32_instrs =
lazy (mk_table [
no_prefixes (["ldc";"i4"], (fun x -> ((mk_ldc_i32 x))));
no_prefixes (["ldc";"i4";"s"], (fun x -> ((mk_ldc_i32 x))));
] : i32_instr instr_table)
let i32_i32_instrs =
lazy (mk_table [
no_prefixes (["ldlen";"multi"], (fun (x,y) -> EI_ldlen_multi (x, y)));
] : i32_i32_instr instr_table)
let real_instrs =
lazy (mk_table [
no_prefixes (["ldc";"r4"], (fun x -> I_arith (AI_ldc (DT_R4, x))));
no_prefixes (["ldc";"r8"], (fun x -> I_arith (AI_ldc (DT_R8, x))));
] : real_instr instr_table)
//let field_instrs =
// lazy (mk_table [
// (volatile_unaligned_prefix (["ldfld"], (fun (x,y) fspec -> I_ldfld(x,y,fspec))));
// (volatile_unaligned_prefix (["stfld"], (fun (x,y) fspec -> I_stfld(x,y,fspec))));
// (volatile_prefix (["ldsfld"], (fun x fspec -> I_ldsfld (x, fspec))));
// (volatile_prefix (["stsfld"], (fun x fspec -> I_stsfld (x, fspec))));
// (no_prefixes (["ldflda"], (fun fspec -> I_ldflda fspec)));
// (no_prefixes (["ldsflda"],(fun fspec -> I_ldsflda fspec)));
// ] : field_instr instr_table)
let method_instrs =
lazy (mk_table [
(tail_prefix (["call"], (fun tl (mspec,y) -> I_call (tl,mspec,y))));
(no_prefixes (["ldftn"], (fun (mspec,y) -> I_ldftn mspec)));
(no_prefixes (["ldvirtftn"], (fun (mspec,y) -> I_ldvirtftn mspec)));
(* nb. set "instance" bit in method id for newobj and callvirt *)
(* This is the behaviour of ILDASM. You'd think it would also do it for *)
(* ldvirtftn but it doesn't. *)
(no_prefixes (["newobj"], (fun (mspec,y) -> I_newobj (set_hasthis_in_mspec CC_instance mspec,y))));
(constraint_tail_prefix (["callvirt"],
(fun (cons,tl) (mspec,y) ->
let mspec2 = set_hasthis_in_mspec CC_instance mspec in
match cons with
| Some ty -> I_callconstraint (tl,ty,mspec2,y)
| None -> I_callvirt (tl,set_hasthis_in_mspec CC_instance mspec,y))));
] : method_instr instr_table)
let string_instrs =
lazy (mk_table [
no_prefixes (["ldstr"], (fun x -> I_ldstr x));
] : string_instr instr_table)
let switch_instrs =
lazy (mk_table [
no_prefixes (["switch"], (fun x -> I_switch x));
] : switch_instr instr_table)
let tok_instrs =
lazy (mk_table [
no_prefixes (["ldtoken"], (fun x -> I_ldtoken x));
] : tok_instr instr_table)
//let sig_instrs =
// lazy (mk_table [
// (tail_prefix (["calli"], (fun tl (x,y) -> I_calli (tl, x, y))));
// ] : sig_instr instr_table)
let type_instrs =
lazy (mk_table [
no_prefixes (["mkrefany"], (fun x -> I_mkrefany x));
no_prefixes (["refanyval"], (fun x -> I_refanyval x));
readonly_prefix (["ldelema"], (fun ro x -> I_ldelema (ro,Rank1ArrayShape,x)));
no_prefixes (["ldelem";"any"], (fun x -> I_ldelem_any (Rank1ArrayShape,x)));
no_prefixes (["stelem";"any"], (fun x -> I_stelem_any (Rank1ArrayShape, x)));
no_prefixes (["newarr"], (fun x -> I_newarr (Rank1ArrayShape,x)));
no_prefixes (["castclass"], (fun x -> I_castclass x));
no_prefixes (["ilzero"], (fun x -> EI_ilzero x));
no_prefixes (["isinst"], (fun x -> I_isinst x));
no_prefixes (["initobj";"any"], (fun x -> I_initobj x));
no_prefixes (["unbox";"any"], (fun x -> I_unbox_any x));
] : type_instr instr_table)
let mk_shape n = ILArrayShape(Array.to_list (Array.create n (None,None)))
let int_type_instrs =
lazy (mk_table [
no_prefixes (["ldelem";"multi"], (fun (x,y) -> (I_ldelem_any (mk_shape x,y))));
no_prefixes (["stelem";"multi"], (fun (x,y) -> (I_stelem_any (mk_shape x,y))));
no_prefixes (["newarr";"multi"], (fun (x,y) -> (I_newarr (mk_shape x,y))));
readonly_prefix (["ldelema";"multi"], (fun ro (x,y) -> (I_ldelema (ro,mk_shape x,y))));
] : int_type_instr instr_table)
let valuetype_instrs =
lazy (mk_table [
no_prefixes (["cpobj"], (fun x -> I_cpobj x));
no_prefixes (["initobj"], (fun x -> I_initobj x));
volatile_unaligned_prefix (["ldobj"], (fun (x,y) z -> I_ldobj (x,y,z)));
volatile_unaligned_prefix (["stobj"], (fun (x,y) z -> I_stobj (x,y,z)));
no_prefixes (["sizeof"], (fun x -> I_sizeof x));
no_prefixes (["box"], (fun x -> I_box x));
no_prefixes (["unbox"], (fun x -> I_unbox x));
] : valuetype_instr instr_table)
(* --------------------------------------------------------------------
* Parser/lexer state.
* -------------------------------------------------------------------- *)
let lexing_bytearray = ref false;;