diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 35612ae98c..ca12cbcf6a 100644 --- a/compiler/lib/generate.ml +++ b/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 diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index f8df4dd73c..8b757708cb 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/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,11 +2223,15 @@ 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 @@ -2234,11 +2239,17 @@ 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 "%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