more primitives, mirror nativeint handling
This commit is contained in:
Gabriel Scherer
Nathanaël Courant
parent
f454d0258b
commit
1909c8f045
9
data.ml
9
data.ml
@ -45,7 +45,9 @@ let onptr f = fun v -> f (Ptr.get v)
|
||||
type value = value_ Ptr.t
|
||||
and value_ =
|
||||
| Int of int
|
||||
| Int32 of int32
|
||||
| Int64 of int64
|
||||
| Nativeint of nativeint
|
||||
| Fun of arg_label * expression option * pattern * expression * env
|
||||
| Function of case list * env
|
||||
| String of bytes
|
||||
@ -138,7 +140,9 @@ let rec is_true = onptr @@ function
|
||||
|
||||
let rec pp_print_value ff = onptr @@ function
|
||||
| Int n -> Format.fprintf ff "%d" n
|
||||
| Int64 n -> Format.fprintf ff "%Ld" n
|
||||
| Int32 n -> Format.fprintf ff "%ldl" n
|
||||
| Int64 n -> Format.fprintf ff "%LdL" n
|
||||
| Nativeint n -> Format.fprintf ff "%ndn" n
|
||||
| Fexpr _ -> Format.fprintf ff "<fexpr>"
|
||||
| Fun _ | Function _ | Prim _ | Lz _ | Fun_with_extra_args _ ->
|
||||
Format.fprintf ff "<function>"
|
||||
@ -212,7 +216,8 @@ let read_caml_int s =
|
||||
let value_of_constant const = ptr @@ match const with
|
||||
| Pconst_integer (s, (None | Some 'l')) ->
|
||||
Int (Int64.to_int (read_caml_int s))
|
||||
| Pconst_integer (s, Some ('L' | 'n')) -> Int64 (read_caml_int s)
|
||||
| Pconst_integer (s, Some 'L') -> Int64 (read_caml_int s)
|
||||
| Pconst_integer (s, Some 'n') -> Nativeint (Int64.to_nativeint (read_caml_int s))
|
||||
| Pconst_integer (_s, Some c) ->
|
||||
Format.eprintf "Unsupported suffix %c@." c;
|
||||
assert false
|
||||
|
||||
11
interp.ml
11
interp.ml
@ -246,12 +246,23 @@ module Compiler_files = struct
|
||||
|
||||
"x86_ast.mli";
|
||||
"x86_proc.ml";
|
||||
"x86_dsl.ml";
|
||||
|
||||
(* backend-specific files *)
|
||||
"arch.ml";
|
||||
"reg.ml";
|
||||
"mach.ml";
|
||||
"proc.ml";
|
||||
"selection.ml";
|
||||
|
||||
"closure.ml";
|
||||
"strmatch.ml";
|
||||
"cmmgen.ml";
|
||||
"linearize.ml";
|
||||
"branch_relaxation.ml";
|
||||
"emitaux.ml";
|
||||
"emit.ml";
|
||||
"asmgen.ml";
|
||||
]
|
||||
|
||||
let bytegen = List.map (Filename.concat "bytecomp") [
|
||||
|
||||
@ -106,6 +106,11 @@ let prims =
|
||||
(unwrap_list unwrap_open_flag)
|
||||
unwrap_int
|
||||
wrap_int );
|
||||
( "caml_sys_close",
|
||||
prim1
|
||||
close_desc
|
||||
unwrap_int
|
||||
wrap_unit );
|
||||
( "caml_ml_set_channel_name",
|
||||
prim2
|
||||
(fun v s ->
|
||||
@ -319,29 +324,30 @@ let prims =
|
||||
("%int64_asr", prim2 Int64.shift_right unwrap_int64 unwrap_int wrap_int64);
|
||||
("%int64_of_int", prim1 Int64.of_int unwrap_int wrap_int64);
|
||||
("%int64_to_int", prim1 Int64.to_int unwrap_int64 wrap_int);
|
||||
("%int64_of_nativeint", prim1 Int64.of_nativeint unwrap_nativeint wrap_int64);
|
||||
("caml_int64_of_string", prim1 Int64.of_string unwrap_string wrap_int64);
|
||||
(* Int32 *)
|
||||
("caml_int32_of_string", prim1 int_of_string unwrap_string wrap_int);
|
||||
("%int32_neg", prim1 ( ~- ) unwrap_int wrap_int);
|
||||
(* Nativeint *)
|
||||
("%nativeint_neg", prim1 Int64.neg unwrap_int64 wrap_int64);
|
||||
("%nativeint_add", prim2 Int64.add unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_sub", prim2 Int64.sub unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_mul", prim2 Int64.mul unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_div", prim2 Int64.div unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_mod", prim2 Int64.rem unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_and", prim2 Int64.logand unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_or", prim2 Int64.logor unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_xor", prim2 Int64.logxor unwrap_int64 unwrap_int64 wrap_int64);
|
||||
("%nativeint_neg", prim1 Nativeint.neg unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_add", prim2 Nativeint.add unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_sub", prim2 Nativeint.sub unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_mul", prim2 Nativeint.mul unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_div", prim2 Nativeint.div unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_mod", prim2 Nativeint.rem unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_and", prim2 Nativeint.logand unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_or", prim2 Nativeint.logor unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
("%nativeint_xor", prim2 Nativeint.logxor unwrap_nativeint unwrap_nativeint wrap_nativeint);
|
||||
( "%nativeint_lsl",
|
||||
prim2 Int64.shift_left unwrap_int64 unwrap_int wrap_int64 );
|
||||
prim2 Nativeint.shift_left unwrap_nativeint unwrap_int wrap_nativeint );
|
||||
( "%nativeint_lsr",
|
||||
prim2 Int64.shift_right_logical unwrap_int64 unwrap_int wrap_int64 );
|
||||
prim2 Nativeint.shift_right_logical unwrap_nativeint unwrap_int wrap_nativeint );
|
||||
( "%nativeint_asr",
|
||||
prim2 Int64.shift_right unwrap_int64 unwrap_int wrap_int64 );
|
||||
("%nativeint_of_int", prim1 Int64.of_int unwrap_int wrap_int64);
|
||||
("%nativeint_to_int", prim1 Int64.to_int unwrap_int64 wrap_int);
|
||||
("caml_nativeint_of_string", prim1 Int64.of_string unwrap_string wrap_int64);
|
||||
prim2 Nativeint.shift_right unwrap_nativeint unwrap_int wrap_nativeint );
|
||||
("%nativeint_of_int", prim1 Nativeint.of_int unwrap_int wrap_nativeint);
|
||||
("%nativeint_to_int", prim1 Nativeint.to_int unwrap_nativeint wrap_int);
|
||||
("caml_nativeint_of_string", prim1 Nativeint.of_string unwrap_string wrap_nativeint);
|
||||
(* Array *)
|
||||
("caml_make_vect", prim2 Array.make unwrap_int id wrap_array_id);
|
||||
("%array_length", prim1 Array.length unwrap_array_id wrap_int);
|
||||
|
||||
@ -1,19 +1,29 @@
|
||||
open Data
|
||||
|
||||
let wrap_int n = ptr @@ Int n
|
||||
|
||||
let unwrap_int = onptr @@ function
|
||||
| Int n -> n
|
||||
| _ -> assert false
|
||||
|
||||
let wrap_int64 n = ptr @@ Int64 n
|
||||
let wrap_int32 n = ptr @@ Int32 n
|
||||
let unwrap_int32 = onptr @@ function
|
||||
| Int32 n -> n
|
||||
| _ -> assert false
|
||||
|
||||
let unwrap_int64 = onptr @@ function
|
||||
let wrap_int64 n = ptr @@ Int64 n
|
||||
let unwrap_int64 = onptr @@ function
|
||||
| Int64 n -> n
|
||||
| _ -> assert false
|
||||
|
||||
let wrap_float f = ptr @@ Float f
|
||||
let wrap_nativeint n = ptr @@ Nativeint n
|
||||
let unwrap_nativeint = onptr @@ function
|
||||
| Nativeint n -> n
|
||||
| v ->
|
||||
Format.eprintf "unwrap_nativeint %a@."
|
||||
pp_print_value (Ptr.create v);
|
||||
assert false
|
||||
|
||||
let wrap_float f = ptr @@ Float f
|
||||
let unwrap_float = onptr @@ function
|
||||
| Float f -> f
|
||||
| _ -> assert false
|
||||
|
||||
@ -65,6 +65,7 @@ external open_descriptor_out
|
||||
|
||||
external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
|
||||
external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
|
||||
external close_desc: int -> unit = "caml_sys_close"
|
||||
|
||||
external set_out_channel_name
|
||||
: out_channel ->
|
||||
@ -113,7 +114,9 @@ external random_seed : unit -> int array = "caml_sys_random_seed"
|
||||
|
||||
let rec seeded_hash_param meaningful total seed = onptr @@ function
|
||||
| Int n -> Hashtbl.seeded_hash_param meaningful total seed n
|
||||
| Int32 n -> Hashtbl.seeded_hash_param meaningful total seed n
|
||||
| Int64 n -> Hashtbl.seeded_hash_param meaningful total seed n
|
||||
| Nativeint n -> Hashtbl.seeded_hash_param meaningful total seed n
|
||||
| Float f -> Hashtbl.seeded_hash_param meaningful total seed f
|
||||
| Tuple _l -> 0
|
||||
| String s ->
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user