Skip to content
Browse files

PR#5774: Add bswap primitives for amd64

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13106 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent f80d01e commit 89bdc103505183125f7bf759c27302a34757af9b @lefessan lefessan committed Nov 29, 2012
View
2 Changes
@@ -46,7 +46,9 @@ Feature wishes:
- PR#5597: add instruction trace option 't' to OCAMLRUNPARAM
- PR#5762: Add primitives for fast access to bigarray dimensions
- PR#5795: Generate sqrtsd opcode instead of external call to sqrt on amd64
+- PR#5769: Allow propagation of Sys.big_endian in native code
- PR#5771: Add primitives for reading 2, 4, 8 bytes in strings and bigarrays
+- PR#5774: Add bswap primitives for amd64
Tools:
- OCamlbuild now features a bin_annot tag to generate .cmt files.
View
3 asmcomp/amd64/arch.ml
@@ -38,6 +38,7 @@ type specific_operation =
| Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
| Ifloatarithmem of float_operation * addressing_mode
(* Float arith operation with memory *)
+ | Ibswap of int (* endiannes conversion *)
| Isqrtf (* floating-point square root *)
| Ifloatsqrtf of addressing_mode (* floating-point square root from memory *)
and float_operation =
@@ -119,3 +120,5 @@ let print_specific_operation printreg op ppf arg =
fprintf ppf "%a %s float64[%a]" printreg arg.(0) (op_name op)
(print_addressing printreg addr)
(Array.sub arg 1 (Array.length arg - 1))
+ | Ibswap i ->
+ fprintf ppf "bswap_%i %a" i printreg arg.(0)
View
12 asmcomp/amd64/emit.mlp
@@ -543,6 +543,18 @@ let emit_instr fallthrough i =
` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n`
| Lop(Ispecific(Ifloatarithmem(op, addr))) ->
` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n`
+ | Lop(Ispecific(Ibswap size)) ->
+ begin match size with
+ | 16 ->
+ ` xchg %ah, %al\n`;
+ ` movzwq {emit_reg16 i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | 32 ->
+ ` bswap {emit_reg32 i.res.(0)}\n`;
+ ` movslq {emit_reg32 i.res.(0)}, {emit_reg i.res.(0)}\n`
+ | 64 ->
+ ` bswap {emit_reg i.res.(0)}\n`
+ | _ -> assert false
+ end
| Lop(Ispecific Isqrtf) ->
` sqrtsd {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
| Lop(Ispecific(Ifloatsqrtf addr)) ->
View
12 asmcomp/amd64/emit_nt.mlp
@@ -537,6 +537,18 @@ let emit_instr fallthrough i =
` add QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n`
| Lop(Ispecific(Ifloatarithmem(op, addr))) ->
` {emit_string(instr_for_floatarithmem op)} {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n`
+ | Lop(Ispecific(Ibswap size)) ->
+ begin match size with
+ | 16 ->
+ ` xchg %ah, %al\n`;
+ ` movzwq {emit_reg i.res.(0)}, {emit_reg16 i.res.(0)}\n`
+ | 32 ->
+ ` bswap {emit_reg32 i.res.(0)}\n`;
+ ` movslq {emit_reg i.res.(0)}, {emit_reg32 i.res.(0)}\n`
+ | 64 ->
+ ` bswap {emit_reg i.res.(0)}\n`
+ | _ -> assert false
+ end
| Lop(Ispecific Isqrtf) ->
` sqrtsd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
| Lop(Ispecific(Ifloatsqrtf addr)) ->
View
27 asmcomp/amd64/selection.ml
@@ -84,8 +84,13 @@ let pseudoregs_for_operation op arg res =
([|res.(0); arg.(1)|], res)
(* One-address unary operations: arg.(0) and res.(0) must be the same *)
| Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _)
- | Iabsf | Inegf ->
+ | Iabsf | Inegf
+ | Ispecific(Ibswap (32|64)) ->
(res, res)
+ (* For xchg, args must be a register allowing access to high 8 bit register
+ (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *)
+ | Ispecific(Ibswap 16) ->
+ ([| rax |], [| rax |])
| Ispecific(Ifloatarithmem(_,_)) ->
let arg' = Array.copy arg in
arg'.(0) <- res.(0);
@@ -107,6 +112,10 @@ let pseudoregs_for_operation op arg res =
(* Other instructions are regular *)
| _ -> raise Use_default
+let inline_ops =
+ [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
+ "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
+
(* The selector class *)
class selector = object (self)
@@ -117,6 +126,15 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000
method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
+method! is_simple_expr e =
+ match e with
+ | Cop(Cextcall(fn, _, _, _), args)
+ when List.mem fn inline_ops ->
+ (* inlined ops are simple if their arguments are *)
+ List.for_all self#is_simple_expr args
+ | _ ->
+ super#is_simple_expr e
+
method select_addressing chunk exp =
let (a, d) = select_addr exp in
(* PR#4625: displacement must be a signed 32-bit immediate *)
@@ -202,6 +220,13 @@ method! select_operation op args =
| _ ->
super#select_operation op args
end
+ | Cextcall("caml_bswap16_direct", _, _, _) ->
+ (Ispecific (Ibswap 16), args)
+ | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+ (Ispecific (Ibswap 32), args)
+ | Cextcall("caml_int64_direct_bswap", _, _, _)
+ | Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
+ (Ispecific (Ibswap 64), args)
| _ -> super#select_operation op args
(* Recognize float arithmetic with mem *)
View
12 asmcomp/closure.ml
@@ -197,6 +197,9 @@ let simplif_prim_pure p (args, approxs) dbg =
begin match p with
Pidentity -> make_const_int x
| Pnegint -> make_const_int (-x)
+ | Pbswap16 ->
+ make_const_int (((x land 0xff) lsl 8) lor
+ ((x land 0xff00) lsr 8))
| Poffsetint y -> make_const_int (x + y)
| _ -> (Uprim(p, args, dbg), Value_unknown)
end
@@ -229,6 +232,15 @@ let simplif_prim_pure p (args, approxs) dbg =
Pidentity -> make_const_ptr x
| Pnot -> make_const_bool(x = 0)
| Pisint -> make_const_bool true
+ | Pctconst c ->
+ begin
+ match c with
+ | Big_endian -> make_const_bool Arch.big_endian
+ | Word_size -> make_const_int (8*Arch.size_int)
+ | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
+ | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
+ | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
+ end
| _ -> (Uprim(p, args, dbg), Value_unknown)
end
| [Value_constptr x; Value_constptr y] ->
View
23 asmcomp/cmmgen.ml
@@ -858,6 +858,7 @@ let simplif_primitive_32bits = function
| Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64")
| Pbigstring_load_64(_) -> Pccall (default_prim "caml_ba_uint8_get64")
| Pbigstring_set_64(_) -> Pccall (default_prim "caml_ba_uint8_set64")
+ | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
| p -> p
let simplif_primitive p =
@@ -974,6 +975,7 @@ let is_unboxed_number = function
| Pstring_load_64(_) -> Boxed_integer Pint64
| Pbigstring_load_32(_) -> Boxed_integer Pint32
| Pbigstring_load_64(_) -> Boxed_integer Pint64
+ | Pbbswap bi -> Boxed_integer bi
| _ -> No_unboxing
end
| _ -> No_unboxing
@@ -1282,6 +1284,16 @@ and transl_prim_1 p arg dbg =
(* Integer operations *)
| Pnegint ->
Cop(Csubi, [Cconst_int 2; transl arg])
+ | Pctconst c ->
+ let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) in
+ begin
+ match c with
+ | Big_endian -> const_of_bool Arch.big_endian
+ | Word_size -> tag_int (Cconst_int (8*Arch.size_int))
+ | Ostype_unix -> const_of_bool (Sys.os_type = "Unix")
+ | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32")
+ | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin")
+ end
| Poffsetint n ->
if no_overflow_lsl n then
add_const (transl arg) (n lsl 1)
@@ -1337,6 +1349,17 @@ and transl_prim_1 p arg dbg =
box_int bi2 (transl_unbox_int bi1 arg)
| Pnegbint bi ->
box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg]))
+ | Pbbswap bi ->
+ let prim = match bi with
+ | Pnativeint -> "nativeint"
+ | Pint32 -> "int32"
+ | Pint64 -> "int64" in
+ box_int bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
+ typ_int, false, Debuginfo.none),
+ [transl_unbox_int bi arg]))
+ | Pbswap16 ->
+ tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, Debuginfo.none),
+ [untag_int (transl arg)]))
| _ ->
fatal_error "Cmmgen.transl_prim_1"
View
BIN boot/ocamlc
Binary file not shown.
View
BIN boot/ocamldep
Binary file not shown.
View
BIN boot/ocamllex
Binary file not shown.
View
10 bytecomp/bytegen.ml
@@ -349,6 +349,14 @@ let comp_primitive p args =
| Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3)
| Parraysetu Pfloatarray -> Kccall("caml_array_unsafe_set_float", 3)
| Parraysetu _ -> Ksetvectitem
+ | Pctconst c ->
+ let const_name = match c with
+ | Big_endian -> "big_endian"
+ | Word_size -> "word_size"
+ | Ostype_unix -> "ostype_unix"
+ | Ostype_win32 -> "ostype_win32"
+ | Ostype_cygwin -> "ostype_cygwin" in
+ Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
| Pisint -> Kisint
| Pisout -> Kisout
| Pbittest -> Kccall("caml_bitvect_test", 2)
@@ -387,6 +395,8 @@ let comp_primitive p args =
| Pbigstring_set_16(_) -> Kccall("caml_ba_uint8_set16", 3)
| Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3)
| Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3)
+ | Pbswap16 -> Kccall("caml_bswap16", 1)
+ | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args
| _ -> fatal_error "Bytegen.comp_primitive"
let is_immed n = immed_min <= n && n <= immed_max
View
12 bytecomp/lambda.ml
@@ -14,6 +14,13 @@ open Misc
open Path
open Asttypes
+type compile_time_constant =
+ | Big_endian
+ | Word_size
+ | Ostype_unix
+ | Ostype_win32
+ | Ostype_cygwin
+
type primitive =
Pidentity
| Pignore
@@ -101,6 +108,11 @@ type primitive =
| Pbigstring_set_16 of bool
| Pbigstring_set_32 of bool
| Pbigstring_set_64 of bool
+ (* Compile time constants *)
+ | Pctconst of compile_time_constant
+ (* byte swap *)
+ | Pbswap16
+ | Pbbswap of boxed_integer
and comparison =
Ceq | Cneq | Clt | Cgt | Cle | Cge
View
12 bytecomp/lambda.mli
@@ -14,6 +14,13 @@
open Asttypes
+type compile_time_constant =
+ | Big_endian
+ | Word_size
+ | Ostype_unix
+ | Ostype_win32
+ | Ostype_cygwin
+
type primitive =
Pidentity
| Pignore
@@ -101,6 +108,11 @@ type primitive =
| Pbigstring_set_16 of bool
| Pbigstring_set_32 of bool
| Pbigstring_set_64 of bool
+ (* Compile time constants *)
+ | Pctconst of compile_time_constant
+ (* byte swap *)
+ | Pbswap16
+ | Pbbswap of boxed_integer
and comparison =
Ceq | Cneq | Clt | Cgt | Cle | Cge
View
10 bytecomp/printlambda.ml
@@ -154,6 +154,14 @@ let primitive ppf = function
| Parraysetu _ -> fprintf ppf "array.unsafe_set"
| Parrayrefs _ -> fprintf ppf "array.get"
| Parraysets _ -> fprintf ppf "array.set"
+ | Pctconst c ->
+ let const_name = match c with
+ | Big_endian -> "big_endian"
+ | Word_size -> "word_size"
+ | Ostype_unix -> "ostype_unix"
+ | Ostype_win32 -> "ostype_win32"
+ | Ostype_cygwin -> "ostype_cygwin" in
+ fprintf ppf "sys.constant_%s" const_name
| Pisint -> fprintf ppf "isint"
| Pisout -> fprintf ppf "isout"
| Pbittest -> fprintf ppf "testbit"
@@ -219,6 +227,8 @@ let primitive ppf = function
| Pbigstring_set_64(unsafe) ->
if unsafe then fprintf ppf "bigarray.array1.unsafe_set64"
else fprintf ppf "bigarray.array1.set64"
+ | Pbswap16 -> fprintf ppf "bswap16"
+ | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
let rec lam ppf = function
| Lvar id ->
View
9 bytecomp/translcore.ml
@@ -150,6 +150,11 @@ let primitives_table = create_hashtable 57 [
"%sequand", Psequand;
"%sequor", Psequor;
"%boolnot", Pnot;
+ "%big_endian", Pctconst Big_endian;
+ "%word_size", Pctconst Word_size;
+ "%ostype_unix", Pctconst Ostype_unix;
+ "%ostype_win32", Pctconst Ostype_win32;
+ "%ostype_cygwin", Pctconst Ostype_cygwin;
"%negint", Pnegint;
"%succint", Poffsetint 1;
"%predint", Poffsetint(-1);
@@ -300,6 +305,10 @@ let primitives_table = create_hashtable 57 [
"%caml_bigstring_set32u", Pbigstring_set_32(true);
"%caml_bigstring_set64", Pbigstring_set_64(false);
"%caml_bigstring_set64u", Pbigstring_set_64(true);
+ "%bswap16", Pbswap16;
+ "%bswap_int32", Pbbswap(Pint32);
+ "%bswap_int64", Pbbswap(Pint64);
+ "%bswap_native", Pbbswap(Pnativeint);
]
let prim_makearray =
View
14 byterun/int64_emul.h
@@ -270,4 +270,18 @@ static int64 I64_of_double(double f)
return res;
}
+static int64 I64_bswap(int64 x)
+{
+ int64 res;
+ res.h = (((x.l & 0x000000FF) << 24) |
+ ((x.l & 0x0000FF00) << 8) |
+ ((x.l & 0x00FF0000) >> 8) |
+ ((x.l & 0xFF000000) >> 24));
+ res.l = (((x.h & 0x000000FF) << 24) |
+ ((x.h & 0x0000FF00) << 8) |
+ ((x.h & 0x00FF0000) >> 8) |
+ ((x.h & 0xFF000000) >> 24));
+ return res;
+}
+
#endif /* CAML_INT64_EMUL_H */
View
9 byterun/int64_native.h
@@ -49,4 +49,13 @@
#define I64_to_double(x) ((double)(x))
#define I64_of_double(x) ((int64)(x))
+#define I64_bswap(x) ((((x) & 0x00000000000000FF) << 56) | \
+ (((x) & 0x000000000000FF00) << 40) | \
+ (((x) & 0x0000000000FF0000) << 24) | \
+ (((x) & 0x00000000FF000000) << 8) | \
+ (((x) & 0x000000FF00000000) >> 8) | \
+ (((x) & 0x0000FF0000000000) >> 24) | \
+ (((x) & 0x00FF000000000000) >> 40) | \
+ (((x) & 0xFF00000000000000) >> 56))
+
#endif /* CAML_INT64_NATIVE_H */
View
65 byterun/ints.c
@@ -114,6 +114,19 @@ intnat caml_safe_mod(intnat p, intnat q)
}
#endif
+CAMLprim value caml_bswap16_direct(value x)
+{
+ return ((((x & 0x00FF) << 8) |
+ ((x & 0xFF00) >> 8)));
+}
+
+CAMLprim value caml_bswap16(value v)
+{
+ intnat x = Int_val(v);
+ return (Val_int ((((x & 0x00FF) << 8) |
+ ((x & 0xFF00) >> 8))));
+}
+
/* Tagged integers */
CAMLprim value caml_int_compare(value v1, value v2)
@@ -296,6 +309,20 @@ CAMLprim value caml_int32_shift_right(value v1, value v2)
CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2)
{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); }
+static int32 swap32(int32 x)
+{
+ return (((x & 0x000000FF) << 24) |
+ ((x & 0x0000FF00) << 8) |
+ ((x & 0x00FF0000) >> 8) |
+ ((x & 0xFF000000) >> 24));
+}
+
+CAMLprim value caml_int32_direct_bswap(value v)
+{ return swap32(v); }
+
+CAMLprim value caml_int32_bswap(value v)
+{ return caml_copy_int32(swap32(Int32_val(v))); }
+
CAMLprim value caml_int32_of_int(value v)
{ return caml_copy_int32(Long_val(v)); }
@@ -486,6 +513,26 @@ CAMLprim value caml_int64_shift_right(value v1, value v2)
CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2)
{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); }
+#ifdef ARCH_SIXTYFOUR
+static value swap64(value x)
+{
+ return (((((x) & 0x00000000000000FF) << 56) |
+ (((x) & 0x000000000000FF00) << 40) |
+ (((x) & 0x0000000000FF0000) << 24) |
+ (((x) & 0x00000000FF000000) << 8) |
+ (((x) & 0x000000FF00000000) >> 8) |
+ (((x) & 0x0000FF0000000000) >> 24) |
+ (((x) & 0x00FF000000000000) >> 40) |
+ (((x) & 0xFF00000000000000) >> 56)));
+}
+
+CAMLprim value caml_int64_direct_bswap(value v)
+{ return swap64(v); }
+#endif
+
+CAMLprim value caml_int64_bswap(value v)
+{ return caml_copy_int64(I64_bswap(Int64_val(v))); }
+
CAMLprim value caml_int64_of_int(value v)
{ return caml_copy_int64(I64_of_intnat(Long_val(v))); }
@@ -738,6 +785,24 @@ CAMLprim value caml_nativeint_shift_right(value v1, value v2)
CAMLprim value caml_nativeint_shift_right_unsigned(value v1, value v2)
{ return caml_copy_nativeint((uintnat)Nativeint_val(v1) >> Int_val(v2)); }
+CAMLprim value caml_nativeint_direct_bswap(value v)
+{
+#ifdef ARCH_SIXTYFOUR
+ return swap64(v);
+#else
+ return swap32(v);
+#endif
+}
+
+CAMLprim value caml_nativeint_bswap(value v)
+{
+#ifdef ARCH_SIXTYFOUR
+ return caml_copy_nativeint(swap64(Nativeint_val(v)));
+#else
+ return caml_copy_nativeint(swap32(Nativeint_val(v)));
+#endif
+}
+
CAMLprim value caml_nativeint_of_int(value v)
{ return caml_copy_nativeint(Long_val(v)); }
View
29 byterun/sys.c
@@ -334,6 +334,35 @@ CAMLprim value caml_sys_random_seed (value unit)
return res;
}
+CAMLprim value caml_sys_const_big_endian(value unit)
+{
+#ifdef ARCH_BIG_ENDIAN
+ return Val_true;
+#else
+ return Val_false;
+#endif
+}
+
+CAMLprim value caml_sys_const_word_size(value unit)
+{
+ return Val_long(8 * sizeof(value));
+}
+
+CAMLprim value caml_sys_const_ostype_unix(value unit)
+{
+ return Val_long(0 == strcmp(OCAML_OS_TYPE,"Unix"));
+}
+
+CAMLprim value caml_sys_const_ostype_win32(value unit)
+{
+ return Val_long(0 == strcmp(OCAML_OS_TYPE,"Win32"));
+}
+
+CAMLprim value caml_sys_const_ostype_cygwin(value unit)
+{
+ return Val_long(0 == strcmp(OCAML_OS_TYPE,"Cygwin"));
+}
+
CAMLprim value caml_sys_get_config(value unit)
{
CAMLparam0 (); /* unit is unused */
View
12 stdlib/sys.mli
@@ -78,6 +78,18 @@ val os_type : string
- ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
- ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
+val unix : bool
+(** True if [Sys.os_type = "Unix"].
+ @since patch included *)
+
+val win32 : bool
+(** True if [Sys.os_type = "Win32"].
+ @since patch included *)
+
+val cygwin : bool
+(** True if [Sys.os_type = "Cygwin"].
+ @since patch included *)
+
val word_size : int
(** Size of one word on the machine currently executing the OCaml
program, in bits: 32 or 64. *)
View
12 stdlib/sys.mlp
@@ -19,9 +19,19 @@
external get_config: unit -> string * int * bool = "caml_sys_get_config"
external get_argv: unit -> string * string array = "caml_sys_get_argv"
+external big_endian : unit -> bool = "%big_endian"
+external word_size : unit -> int = "%word_size"
+external unix : unit -> bool = "%ostype_unix"
+external win32 : unit -> bool = "%ostype_win32"
+external cygwin : unit -> bool = "%ostype_cygwin"
let (executable_name, argv) = get_argv()
-let (os_type, word_size, big_endian) = get_config()
+let (os_type, _, _) = get_config()
+let big_endian = big_endian ()
+let word_size = word_size ()
+let unix = unix ()
+let win32 = win32 ()
+let cygwin = cygwin ()
let max_array_length = (1 lsl (word_size - 10)) - 1;;
let max_string_length = word_size / 8 * max_array_length - 1;;

0 comments on commit 89bdc10

Please sign in to comment.
Something went wrong with that request. Please try again.