added primitives, but didn't update backend yet

bytecomp/bytegen.ml

@@ -626,17 +626,17 @@ 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 = _; signedness = Signed; op = Ceq }
+  | Pbintcomp(_, Ceq) | Pnaked_int_cmp {size = _; op = Ceq }
     -> Kccall("caml_equal", 2)
-  | Pbintcomp(_, Cne) | Pnaked_int_cmp {size = _; signedness = Signed; op = Cne }
+  | Pbintcomp(_, Cne) | Pnaked_int_cmp {size = _; op = Cne }
     -> Kccall("caml_notequal", 2)
-  | Pbintcomp(_, Clt) | Pnaked_int_cmp {size = _; signedness = Signed; op = Clt }
+  | Pbintcomp(_, Clt) | Pnaked_int_cmp {size = _; op = Clt }
     -> Kccall("caml_lessthan", 2)
-  | Pbintcomp(_, Cgt) | Pnaked_int_cmp {size = _; signedness = Signed; op = Cgt }
+  | Pbintcomp(_, Cgt) | Pnaked_int_cmp {size = _; op = Cgt }
     -> Kccall("caml_greaterthan", 2)
-  | Pbintcomp(_, Cle) | Pnaked_int_cmp {size = _; signedness = Signed; op = Cle }
+  | Pbintcomp(_, Cle) | Pnaked_int_cmp {size = _; op = Cle }
     -> Kccall("caml_lessequal", 2)
-  | Pbintcomp(_, Cge) | Pnaked_int_cmp {size = _; signedness = Signed; op = Cge }
+  | Pbintcomp(_, Cge) | Pnaked_int_cmp {size = _; op = 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)
@@ -755,7 +755,6 @@ 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_cmp { signedness = Unsigned; _ }
   | Pnaked_int_cast _ | Pnaked_int_binop _
     ->
       fatal_error "Bytegen.comp_primitive"

lambda/lambda.ml

@@ -124,13 +124,6 @@ type region_close =
   | Rc_nontail
   | Rc_close_at_apply
 
-type signedness =
-  | Signed
-  | Unsigned
-
-type overflow_behavior =
-  | Wrap
-  | Raise
 
 type naked_integer_binop =
   | Add
@@ -142,7 +135,8 @@ type naked_integer_binop =
   | Or
   | Xor
   | Shl
-  | Shr
+  | Lshr
+  | Ashr
 
 
 type primitive =
@@ -255,18 +249,14 @@ type primitive =
   | Pnaked_int_cast of
     { src : unboxed_integer
     ; dst : unboxed_integer
-    ; overflow_behavior : overflow_behavior
     }
   | Pnaked_int_binop of
     { op : naked_integer_binop
-    ; signedness : signedness
     ; size : unboxed_integer
-    ; overflow_behavior : overflow_behavior
     }
   | Pnaked_int_cmp of
     { op : integer_comparison
     ; size : unboxed_integer
-    ; signedness : signedness
     }
 
   (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *)
@@ -2188,16 +2178,12 @@ let primitive_can_raise prim =
   | Preinterpret_unboxed_int64_as_tagged_int63
   | Parray_element_size_in_bytes _ | Ppeek _ | Ppoke _ ->
     false
-  | Pnaked_int_binop { overflow_behavior = Raise ; _}
-  | Pnaked_int_binop { op = Div | Rem ; _ }
-  | Pnaked_int_cast { overflow_behavior = Raise ; _}
+  | Pnaked_int_binop { op = Div | Rem ; size = _ }
     -> true
-  | Pnaked_int_cast { overflow_behavior = Wrap ; _}
-  | Pnaked_int_binop { overflow_behavior = Wrap ;
-                       op =  Add | Sub | Mul | And | Or | Xor | Shl | Shr
-                     ; signedness = _
-                     }
+  | Pnaked_int_binop { op =  Add | Sub | Mul | And | Or | Xor | Shl | Lshr | Ashr
+                     ; size = _ }
     -> false
+  | Pnaked_int_cast { src = _; dst = _ } -> false
 
 let constant_layout: constant -> layout = function
   | Const_int _ | Const_char _ -> non_null_value Pintval

lambda/lambda.mli

@@ -104,14 +104,6 @@ type region_close =
     tail call because the outer region needs to end there.)
 *)
 
-type signedness =
-  | Signed
-  | Unsigned
-
-type overflow_behavior =
-  | Wrap
-  | Raise
-
 type naked_integer_binop =
   | Add
   | Sub
@@ -122,7 +114,8 @@ type naked_integer_binop =
   | Or
   | Xor
   | Shl
-  | Shr
+  | Lshr
+  | Ashr
 
 (* CR layouts v5: When we add more blocks of non-scannable values, consider
    whether some of the primitives specific to ufloat records
@@ -252,18 +245,14 @@ type primitive =
   | Pnaked_int_cast of
     { src : unboxed_integer
     ; dst : unboxed_integer
-    ; overflow_behavior : overflow_behavior
     }
   | Pnaked_int_binop of
     { op : naked_integer_binop
-    ; signedness : signedness
     ; size : unboxed_integer
-    ; overflow_behavior : overflow_behavior
     }
   | Pnaked_int_cmp of
     { op : integer_comparison
     ; size : unboxed_integer
-    ; signedness : signedness
     }
 
   (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *)

lambda/matching.ml

@@ -3178,18 +3178,18 @@ let combine_constant value_kind loc arg cst partial ctx def
           arg const_lambda_list
     | Const_unboxed_int32 _ ->
         make_test_sequence value_kind loc fail
-          (Pnaked_int_cmp {op = Cne; size = Unboxed_int32; signedness = Signed})
-          (Pnaked_int_cmp {op = Clt; size = Unboxed_int32; signedness = Signed})
+          (Pnaked_int_cmp {op = Cne; size = Unboxed_int32})
+          (Pnaked_int_cmp {op = Clt; size = Unboxed_int32})
           arg const_lambda_list
     | Const_unboxed_int64 _ ->
         make_test_sequence value_kind loc fail
-          (Pnaked_int_cmp {op = Cne; size = Unboxed_int64; signedness = Signed})
-          (Pnaked_int_cmp {op = Clt; size = Unboxed_int64; signedness = Signed})
+          (Pnaked_int_cmp {op = Cne; size = Unboxed_int64})
+          (Pnaked_int_cmp {op = Clt; size = Unboxed_int64})
           arg const_lambda_list
     | Const_unboxed_nativeint _ ->
         make_test_sequence value_kind loc fail
-          (Pnaked_int_cmp {op = Cne; size = Unboxed_nativeint; signedness = Signed})
-          (Pnaked_int_cmp {op = Clt; size = Unboxed_nativeint; signedness = Signed})
+          (Pnaked_int_cmp {op = Cne; size = Unboxed_nativeint})
+          (Pnaked_int_cmp {op = Clt; size = Unboxed_nativeint})
           arg const_lambda_list
   in
   (lambda1, Jumps.union local_jumps total)

lambda/printlambda.ml

@@ -343,17 +343,6 @@ let boxed_integer_mark name bi m =
 let print_boxed_integer name ppf bi m =
   fprintf ppf "%s" (boxed_integer_mark name bi m);;
 
-let unboxed_integer_mark name bi m =
-  match bi with
-  | Unboxed_nativeint -> Printf.sprintf "Nativeint_u.%s%s" name (locality_kind m)
-  | Unboxed_int8 -> Printf.sprintf "Int8_u.%s%s" name (locality_kind m)
-  | Unboxed_int16 -> Printf.sprintf "Int16_u.%s%s" name (locality_kind m)
-  | Unboxed_int32 -> Printf.sprintf "Int32_u.%s%s" name (locality_kind m)
-  | Unboxed_int64 -> Printf.sprintf "Int64_u.%s%s" name (locality_kind m)
-
-let print_unboxed_integer name ppf bi m =
-  fprintf ppf "%s" (unboxed_integer_mark name bi m);;
-
 let boxed_float_mark name bf m =
   match bf with
   | Boxed_float64 -> Printf.sprintf "Float.%s%s" name (locality_kind m)
@@ -487,66 +476,49 @@ let peek_or_poke ppf (pp : peek_or_poke) =
   | Ppp_unboxed_int64 -> fprintf ppf "unboxed_int64"
   | Ppp_unboxed_nativeint -> fprintf ppf "unboxed_nativeint"
 
-let naked_integer signedness size =
-  match (signedness : Lambda.signedness), (size : Primitive.unboxed_integer) with
-  | Unsigned, Unboxed_int8 -> "naked_u8"
-  | Unsigned, Unboxed_int16 -> "naked_u16"
-  | Unsigned, Unboxed_int32 -> "naked_u32"
-  | Unsigned, Unboxed_nativeint -> "naked_unativeint"
-  | Unsigned, Unboxed_int64 -> "naked_u64"
-  | Signed, Unboxed_int8 -> "naked_i8"
-  | Signed, Unboxed_int16 -> "naked_i16"
-  | Signed, Unboxed_int32 -> "naked_i32"
-  | Signed, Unboxed_nativeint -> "naked_nativeint"
-  | Signed, Unboxed_int64 -> "naked_i64"
-
-let naked_arithmetic_primitive signedness binop size =
+let naked_integer size =
+  match (size : Primitive.unboxed_integer) with
+  | Unboxed_int8 -> "naked_i8"
+  | Unboxed_int16 -> "naked_i16"
+  | Unboxed_int32 -> "naked_i32"
+  | Unboxed_nativeint -> "naked_nativeint"
+  | Unboxed_int64 -> "naked_i64"
+
+let naked_integer_binop binop ni =
   let binop =
-    match
-      (signedness : Lambda.signedness),
-      (binop : Lambda.naked_integer_binop)
-    with
-    (* there's no distinction between signed/unsigned for most operators *)
-    | (Signed | Unsigned), Add -> "add"
-    | (Signed | Unsigned), Sub -> "sub"
-    | (Signed | Unsigned), Mul -> "mul"
-    | (Signed | Unsigned), And -> "and"
-    | (Signed | Unsigned), Or -> "or"
-    | (Signed | Unsigned), Xor -> "xor"
-    | (Signed | Unsigned), Shl -> "shl"
-    | Signed, Div -> "sdiv"
-    | Unsigned, Div -> "udiv"
-    | Signed, Rem -> "srem"
-    | Unsigned, Rem -> "urem"
-    | Unsigned, Shr -> "lshr"
-    | Signed, Shr -> "ashr"
-  in
-  Printf.sprintf "%s_%s" binop (naked_integer signedness size)
-
-let naked_arithmetic_conv signedness ~src ~dst =
-  let bits : Primitive.unboxed_integer -> int = function
-    | Unboxed_int8 -> 8
-    | Unboxed_int16 -> 16
-    | Unboxed_int32 -> 32
-    | Unboxed_nativeint -> failwith "TODO"
-    | Unboxed_int64 -> 64
-  in
-  let operation =
-    let cmp = Int.compare (bits src) (bits dst) in
-    if cmp > 0 then
-      "trunc"
-    else if cmp = 0 then
-      "bitcast"
-    else
-      match signedness with
-      | Signed -> "sext"
-      | Unsigned -> "zext"
+    match (binop : naked_integer_binop) with
+    | Add -> "add"
+    | Sub -> "sub"
+    | Mul -> "mul"
+    | Div -> "sdiv"
+    | Rem -> "srem"
+    | And -> "and"
+    | Or -> "or"
+    | Xor -> "xor"
+    | Shl -> "shl"
+    | Lshr  -> "lshr"
+    | Ashr  -> "ashr"
   in
+  Printf.sprintf "%%%s_%s" binop (naked_integer ni)
+
+let naked_integer_cast ~src ~dst =
   Printf.sprintf
-    "%s_%s_to_%s"
-    operation
-    (naked_integer signedness src)
-    (naked_integer signedness dst)
+    "%%%s_of_%s"
+    (naked_integer dst)
+    (naked_integer src)
+
+
+  let naked_integer_cmp op ni =
+    let op =
+      match op with
+      | Ceq -> "eq"
+      | Cne -> "ne"
+      | Clt -> "lt"
+      | Cgt -> "gt"
+      | Cle -> "le"
+      | Cge -> "ge"
+    in
+    Printf.sprintf "%%%s_%s" op (naked_integer ni)
 
 let primitive ppf = function
   | Pbytes_to_string -> fprintf ppf "bytes_to_string"
@@ -809,12 +781,15 @@ let primitive ppf = function
   | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi alloc_heap
   | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi alloc_heap
   | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi alloc_heap
-  | Punboxed_int_comp(bi, Ceq) -> print_unboxed_integer "==" ppf bi alloc_heap
-  | Punboxed_int_comp(bi, Cne) -> print_unboxed_integer "!=" ppf bi alloc_heap
-  | Punboxed_int_comp(bi, Clt) -> print_unboxed_integer "<" ppf bi alloc_heap
-  | Punboxed_int_comp(bi, Cgt) -> print_unboxed_integer ">" ppf bi alloc_heap
-  | Punboxed_int_comp(bi, Cle) -> print_unboxed_integer "<=" ppf bi alloc_heap
-  | Punboxed_int_comp(bi, Cge) -> print_unboxed_integer ">=" ppf bi alloc_heap
+  | Pnaked_int_cmp { op; size } ->
+    pp_print_string ppf (naked_integer_cmp op size)
+  | Pnaked_int_binop { op; size } ->
+    pp_print_string ppf  (naked_integer_binop op size)
+  | Pnaked_int_cast { src; dst } ->
+    pp_print_string ppf
+      (naked_integer_cast
+         ~src
+         ~dst)
   | Pbigarrayref(unsafe, _n, kind, layout) ->
       print_bigarray "get" unsafe kind ppf layout
   | Pbigarrayset(unsafe, _n, kind, layout) ->
@@ -1118,7 +1093,7 @@ let name_of_primitive = function
   | Plsrbint _ -> "Plsrbint"
   | Pasrbint _ -> "Pasrbint"
   | Pbintcomp _ -> "Pbintcomp"
-  | Punboxed_int_comp _ -> "Punboxed_int_comp"
+  | Pnaked_int_cmp _ -> "Pnaked_int_cmp"
   | Pbigarrayref _ -> "Pbigarrayref"
   | Pbigarrayset _ -> "Pbigarrayset"
   | Pbigarraydim _ -> "Pbigarraydim"
@@ -1213,8 +1188,14 @@ let name_of_primitive = function
       "Preinterpret_tagged_int63_as_unboxed_int64"
   | Preinterpret_unboxed_int64_as_tagged_int63 ->
       "Preinterpret_unboxed_int64_as_tagged_int63"
+<<<<<<< HEAD
   | Ppeek _ -> "Ppeek"
   | Ppoke _ -> "Ppoke"
+||||||| parent of 3cf77a508 (added primitives, but didn't update backend yet)
+=======
+  | Pnaked_int_cast _ -> "Pnaked_int_cast"
+  | Pnaked_int_binop _ -> "Pnaked_int_binop"
+>>>>>>> 3cf77a508 (added primitives, but didn't update backend yet)
 
 let zero_alloc_attribute ppf check =
   match check with

lambda/printlambda.mli

@@ -17,6 +17,9 @@ open Lambda
 
 open Format
 
+val naked_integer_binop : naked_integer_binop ->  unboxed_integer -> string
+val naked_integer_cast :  src:unboxed_integer -> dst:unboxed_integer -> string
+val naked_integer_cmp : integer_comparison  -> unboxed_integer -> string
 val integer_comparison: formatter -> integer_comparison -> unit
 val float_comparison: float_comparison -> string
 val structured_constant: formatter -> structured_constant -> unit