added bytecode compilation

bytecomp/bytegen.ml

@@ -626,18 +626,12 @@ let comp_primitive stack_info p sz args =
   | Plslbint(bi,_) -> comp_bint_primitive bi "shift_left" args
   | Plsrbint(bi,_) -> comp_bint_primitive bi "shift_right_unsigned" args
   | Pasrbint(bi,_) -> comp_bint_primitive bi "shift_right" args
-  | Pbintcomp(_, Ceq) | Pnaked_int_cmp {size = _; op = Ceq }
-    -> Kccall("caml_equal", 2)
-  | Pbintcomp(_, Cne) | Pnaked_int_cmp {size = _; op = Cne }
-    -> Kccall("caml_notequal", 2)
-  | Pbintcomp(_, Clt) | Pnaked_int_cmp {size = _; op = Clt }
-    -> Kccall("caml_lessthan", 2)
-  | Pbintcomp(_, Cgt) | Pnaked_int_cmp {size = _; op = Cgt }
-    -> Kccall("caml_greaterthan", 2)
-  | Pbintcomp(_, Cle) | Pnaked_int_cmp {size = _; op = Cle }
-    -> Kccall("caml_lessequal", 2)
-  | Pbintcomp(_, Cge) | Pnaked_int_cmp {size = _; op = Cge }
-    -> Kccall("caml_greaterequal", 2)
+  | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
+  | Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2)
+  | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
+  | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2)
+  | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2)
+  | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2)
   | Pbigarrayref(_, n, Pbigarray_float32_t, _) -> Kccall("caml_ba_float32_get_" ^ Int.to_string n, n + 1)
   | Pbigarrayset(_, n, Pbigarray_float32_t, _) -> Kccall("caml_ba_float32_set_" ^ Int.to_string n, n + 2)
   | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ Int.to_string n, n + 1)
@@ -755,7 +749,7 @@ let comp_primitive stack_info p sz args =
   | Pprobe_is_enabled _
   | Punbox_float _ | Pbox_float (_, _) | Punbox_int _ | Pbox_int _
   | Ptag_int _ | Puntag_int _
-  | Pnaked_int_cast _ | Pnaked_int_binop _
+  | Pnaked_int_cast _ | Pnaked_int_binop _ | Pnaked_int_cmp _
     ->
       fatal_error "Bytegen.comp_primitive"
   | Ppeek _ | Ppoke _ ->
@@ -1155,6 +1149,12 @@ and comp_expr stack_info env exp sz cont =
   | Lprim(Pfloatfield (n, _, _), args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       comp_args stack_info env args sz (Kgetfloatfield n :: cont)
+  | Lprim(Pnaked_int_cmp { op; size }, args, loc) ->
+    comp_expr stack_info env (Lambda.naked_int_cmp ~op ~size args loc) sz cont
+  | Lprim(Pnaked_int_cast {src;dst}, args, loc) ->
+    comp_expr stack_info env (Lambda.naked_int_cast ~src ~dst args loc) sz cont
+  | Lprim(Pnaked_int_binop {op; size}, args, loc) ->
+    comp_expr stack_info env (Lambda.naked_int_binop ~op ~size args loc) sz cont
   | Lprim(p, args, _) ->
       let nargs = List.length args - 1 in
       comp_args stack_info env args sz

lambda/lambda.ml

@@ -2655,3 +2655,125 @@ let rec ignorable_product_element_kind_involves_int
   | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> false
   | Pproduct_ignorable kinds ->
     List.exists ignorable_product_element_kind_involves_int kinds
+
+(* Functions for simulating naked int primitives. This is used for bytecode
+   compilation which doesn't support naked int primitives directly *)
+
+module Bytecode_repr = struct
+  (* naked integers are boxed or tagged as appropriate in bytecode *)
+  type t =
+    | Tagged of unboxed_integer
+    | Boxed of boxed_integer
+
+  let bits = function
+    | Unboxed_int8 -> 8
+    | Unboxed_int16 -> 16
+    | Unboxed_int32 -> 32
+    | Unboxed_nativeint -> Targetint.size
+    | Unboxed_int64 -> 64
+
+  let of_size = function
+    | (Unboxed_int8 | Unboxed_int16) as size -> Tagged size
+    | Unboxed_int32 -> Boxed Boxed_int32
+    | Unboxed_nativeint -> Boxed Boxed_nativeint
+    | Unboxed_int64 -> Boxed Boxed_int64
+
+  let wrap = function
+    | Tagged size -> Ptag_int size
+    | Boxed boxed -> Pbox_int (boxed, alloc_heap)
+
+  let unwrap = function
+    | Tagged size -> Puntag_int size
+    | Boxed boxed -> Punbox_int boxed
+end
+
+
+let naked_int_cast ~src ~dst args loc =
+  let sign_extend arg ~bits =
+    let int_size = Targetint.size - 1 in
+    let unused_bits = int_size - bits in
+    if unused_bits = 0 then arg
+    else
+      let unused_bits = Lconst (const_int unused_bits) in
+      let left_aligned = Lprim (Plslint, [arg; unused_bits], loc) in
+      Lprim (Pasrint, [left_aligned; unused_bits], loc)
+  in
+  let src = Bytecode_repr.of_size src in
+  let dst = Bytecode_repr.of_size dst in
+  let arg = Lprim (Bytecode_repr.wrap src, args, loc) in
+  let converted =
+    match src, dst with
+    | Tagged src, Tagged dst ->
+      if Bytecode_repr.bits src <= Bytecode_repr.bits dst
+      then arg
+      else sign_extend arg ~bits:(Bytecode_repr.bits dst)
+    | Boxed src, Tagged dst ->
+      sign_extend
+        ~bits:(Bytecode_repr.bits dst)
+        (Lprim (Pintofbint src, args, loc))
+    | Tagged (_ : unboxed_integer), Boxed dst ->
+      Lprim (Pbox_int (dst, alloc_local), [arg], loc)
+    | Boxed src, Boxed dst ->
+      Lprim (Pcvtbint (src, dst, alloc_local), [ arg ], loc)
+  in
+  Lprim (Bytecode_repr.unwrap dst, [converted], loc)
+
+let naked_int_cmp ~op ~size args loc =
+  let repr = Bytecode_repr.of_size size in
+  let wrap = Bytecode_repr.wrap repr in
+  let args = ListLabels.map args ~f:(fun arg ->
+    Lprim(wrap, [arg], loc))
+  in
+  let prim =
+    match repr with
+    | Tagged (_ : unboxed_integer) -> Pintcomp op
+    | Boxed boxed -> Pbintcomp (boxed, op)
+  in
+  Lprim (prim, args, loc)
+
+let naked_int_binop ~op ~size args loc =
+  let repr = Bytecode_repr.of_size size in
+  let wrap = Bytecode_repr.wrap repr in
+  let args = ListLabels.map args ~f:(fun arg ->
+    Lprim (wrap, [arg], loc))
+  in
+  let go ?unbox_second_argument prim =
+    match args with
+    | [] | [_] | _::_::_::_ ->
+      Misc.fatal_error "naked_int_binop expected two arguments"
+    | [l; r] ->
+      let args =
+        match unbox_second_argument with
+        | None -> [l; r]
+        | Some boxed ->  [l; Lprim (Pintofbint boxed, [r], loc)]
+      in
+      Lprim (Bytecode_repr.unwrap repr, [Lprim (prim, args, loc)], loc)
+
+  in
+  match op, repr with
+  | Add , Tagged (_ : unboxed_integer) -> go Paddint
+  | Sub , Tagged (_ : unboxed_integer) -> go Psubint
+  | Mul , Tagged (_ : unboxed_integer) -> go Pmulint
+  | Div , Tagged (_ : unboxed_integer) -> go (Pdivint Safe)
+  | Rem , Tagged (_ : unboxed_integer) -> go (Pmodint Safe)
+  | And , Tagged (_ : unboxed_integer) -> go Pandint
+  | Or  , Tagged (_ : unboxed_integer) -> go Porint
+  | Xor , Tagged (_ : unboxed_integer) -> go Pxorint
+  | Shl , Tagged (_ : unboxed_integer) -> go Plslint
+  | Lshr, Tagged (_ : unboxed_integer) -> go Plsrint
+  | Ashr, Tagged (_ : unboxed_integer) -> go Pasrint
+  | Add , Boxed boxed -> go (Paddbint (boxed, alloc_heap))
+  | Sub , Boxed boxed -> go (Psubbint (boxed, alloc_heap))
+  | Mul , Boxed boxed -> go (Pmulbint (boxed, alloc_heap))
+  | Div , Boxed boxed -> go (Pdivbint {size=boxed; is_safe=Safe; mode=alloc_heap})
+  | Rem , Boxed boxed -> go (Pmodbint {size=boxed; is_safe=Safe; mode=alloc_heap})
+  | And , Boxed boxed -> go (Pandbint (boxed, alloc_heap))
+  | Or  , Boxed boxed -> go (Porbint  (boxed, alloc_heap))
+  | Xor , Boxed boxed -> go (Pxorbint (boxed, alloc_heap))
+  (* boxed integer shifts take a tagged integer as the second argument *)
+  | Shl , Boxed boxed ->
+    go (Plslbint (boxed, alloc_heap)) ~unbox_second_argument:boxed
+  | Lshr, Boxed boxed ->
+    go (Plsrbint (boxed, alloc_heap)) ~unbox_second_argument:boxed
+  | Ashr, Boxed boxed ->
+    go (Pasrbint (boxed, alloc_heap)) ~unbox_second_argument:boxed

lambda/lambda.mli

@@ -1245,3 +1245,21 @@ val primitive_can_raise : primitive -> bool
 val count_initializers_array_kind : array_kind -> int
 val ignorable_product_element_kind_involves_int :
   ignorable_product_element_kind -> bool
+
+(** Equivalent to applying [Pnaked_int_cast] without actually using the
+    primitive. This is used for bytecode compilation which doesn't support
+    naked integer primitives. *)
+val naked_int_cast : src:unboxed_integer ->
+  dst:unboxed_integer -> lambda list -> scoped_location -> lambda
+
+(** Equivalent to applying [Pnaked_int_cmp] without actually using the
+    primitive. This is used for bytecode compilation which doesn't support
+    naked integer primitives. *)
+val naked_int_cmp : op:integer_comparison ->
+  size:unboxed_integer -> lambda list -> scoped_location -> lambda
+
+(** Equivalent to applying [Pnaked_int_binop] without actually using the
+    primitive. This is used for bytecode compilation which doesn't support
+    naked integer primitives. *)
+val naked_int_binop : op:naked_integer_binop ->
+  size:unboxed_integer -> lambda list -> scoped_location -> lambda