phys_equal

Author: hhugo

compiler/lib/generate.ml

@@ -343,6 +343,8 @@ let plus_int x y =
 
 let bool e = J.ECond (e, one, zero)
 
+let bool_not e = J.ECond (e, zero, one)
+
 (****)
 
 let source_location ctx position pc =
@@ -1398,6 +1400,20 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t
               | _ -> J.EBin (J.Plus, ca, cb)
             in
             return (add ca cb)
+        | Extern "%phys_equal", [x; y] ->
+           let* cx = access' ~ctx x in
+           let* cy = access' ~ctx y in
+            return (bool (J.call
+              (J.dot (s_var "Object") (Utf8_string.of_string_exn "is"))
+              [ cx; cy ]
+              loc))
+        | Extern "%not_phys_equal", [x; y] ->
+            let* cx = access' ~ctx x in
+            let* cy = access' ~ctx y in
+            return (bool_not (J.call
+              (J.dot (s_var "Object") (Utf8_string.of_string_exn "is"))
+              [ cx; cy ]
+              loc))
         | Extern name, l -> (
             let name = Primitive.resolve name in
             match internal_prim name with

compiler/lib/parse_bytecode.ml

@@ -358,6 +358,7 @@ module Hints = struct
         ; layout : Lambda.bigarray_layout
         }
     | Hint_primitive of Primitive.description
+    | Hint_phys_equal
 
   module Int_table = Hashtbl.Make (Int)
 
@@ -2222,23 +2223,33 @@ and compile infos pc state (instrs : instr list) =
 
         if debug_parser ()
         then Format.printf "%a = mk_bool(%a == %a)@." Var.print x Var.print y Var.print z;
+        let hints = Hints.find infos.hints pc in
+        let prim =
+          if List.mem Hints.Hint_phys_equal ~set:hints then Extern "%phys_equal" else Eq
+        in
         compile
           infos
           (pc + 1)
           (State.pop 1 state)
-          (Let (x, Prim (Eq, [ Pv y; Pv z ])) :: instrs)
+          (Let (x, Prim (prim, [ Pv y; Pv z ])) :: instrs)
     | NEQ ->
         let y = State.accu state in
         let z = State.peek 0 state in
         let x, state = State.fresh_var state in
 
         if debug_parser ()
         then Format.printf "%a = mk_bool(%a != %a)@." Var.print x Var.print y Var.print z;
+        let hints = Hints.find infos.hints pc in
+        let prim =
+          if List.mem Hints.Hint_phys_equal ~set:hints
+          then Extern "%not_phys_equal"
+          else Neq
+        in
         compile
           infos
           (pc + 1)
           (State.pop 1 state)
-          (Let (x, Prim (Neq, [ Pv y; Pv z ])) :: instrs)
+          (Let (x, Prim (prim, [ Pv y; Pv z ])) :: instrs)
     | LTINT ->
         let y = State.accu state in
         let z = State.peek 0 state in