Initial refactoring of To_cmm (#619)

backend/cmm_helpers.ml

@@ -3767,3 +3767,338 @@ let emit_preallocated_blocks preallocated_blocks cont =
   in
   let c1 = emit_gc_roots_table ~symbols cont in
   List.fold_left preallocate_block c1 preallocated_blocks
+
+(* Helper functions and values used by Flambda 2. *)
+
+let typ_int64 =
+  match Arch.size_int with
+  | 4 -> [| Cmm.Int; Cmm.Int |]
+  | 8 -> [| Cmm.Int |]
+  | _ -> Misc.fatal_errorf "Unsupported Arch.size_int = %d" Arch.size_int
+
+let void = Ctuple []
+
+let unit ~dbg = Cconst_int (1, dbg)
+
+let var v = Cvar v
+
+let symbol_from_string ~dbg sym = Cconst_symbol (sym, dbg)
+
+let float ~dbg f = Cconst_float (f, dbg)
+
+(* CR Gbury: this conversion int -> nativeint is potentially unsafe when
+   cross-compiling for 64-bit on a 32-bit host *)
+let int ~dbg i = natint_const_untagged dbg (Nativeint.of_int i)
+
+let int32 ~dbg i = natint_const_untagged dbg (Nativeint.of_int32 i)
+
+(* CR Gbury: this conversion int64 -> nativeint is potentially unsafe when
+   cross-compiling for 64-bit on a 32-bit host *)
+let int64 ~dbg i = natint_const_untagged dbg (Int64.to_nativeint i)
+
+let nativeint ~dbg i = natint_const_untagged dbg i
+
+let letin v ~defining_expr ~body =
+  match body with
+  | Cvar v' when Backend_var.same (Backend_var.With_provenance.var v) v' ->
+    defining_expr
+  | Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
+  | Clet _ | Clet_mut _ | Cphantom_let _ | Cassign _ | Ctuple _ | Cop _
+  | Csequence _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _
+  | Cregion _ | Ctail _ ->
+    Clet (v, defining_expr, body)
+
+let letin_mut v ty e body = Clet_mut (v, ty, e, body)
+
+let assign x e = Cassign (x, e)
+
+let sequence x y =
+  match x, y with
+  | Ctuple [], _ -> y
+  | _, Ctuple [] -> x
+  | _, _ -> Csequence (x, y)
+
+let ite ~dbg ~then_dbg ~then_ ~else_dbg ~else_ cond =
+  Cifthenelse
+    ( cond,
+      then_dbg,
+      then_,
+      else_dbg,
+      else_,
+      dbg,
+      (* CR-someday poechsel: Put a correct value kind here *)
+      Vval Pgenval )
+
+let trywith ~dbg ~kind ~body ~exn_var ~handler () =
+  (* CR-someday poechsel: Put a correct value kind here *)
+  Ctrywith (body, kind, exn_var, handler, dbg, Vval Pgenval)
+
+type static_handler =
+  int
+  * (Backend_var.With_provenance.t * Cmm.machtype) list
+  * Cmm.expression
+  * Debuginfo.t
+
+let handler ~dbg id vars body = id, vars, body, dbg
+
+let cexit id args trap_actions = Cmm.Cexit (Cmm.Lbl id, args, trap_actions)
+
+let trap_return arg trap_actions =
+  Cmm.Cexit (Cmm.Return_lbl, [arg], trap_actions)
+
+let create_ccatch ~rec_flag ~handlers ~body =
+  let rec_flag = if rec_flag then Cmm.Recursive else Cmm.Nonrecursive in
+  Cmm.Ccatch (rec_flag, handlers, body, Vval Pgenval)
+
+let unary op ~dbg x = Cop (op, [x], dbg)
+
+let binary op ~dbg x y = Cop (op, [x; y], dbg)
+
+let int_of_float = unary Cintoffloat
+
+let float_of_int = unary Cfloatofint
+
+let lsl_int_caml_raw ~dbg arg1 arg2 =
+  incr_int (lsl_int (decr_int arg1 dbg) arg2 dbg) dbg
+
+let lsr_int_caml_raw ~dbg arg1 arg2 =
+  Cop (Cor, [lsr_int arg1 arg2 dbg; Cconst_int (1, dbg)], dbg)
+
+let asr_int_caml_raw ~dbg arg1 arg2 =
+  Cop (Cor, [asr_int arg1 arg2 dbg; Cconst_int (1, dbg)], dbg)
+
+let eq ~dbg x y =
+  match x, y with
+  | Cconst_int (n, _), Cop (Csubi, [Cconst_int (m, _); c], _)
+  | Cop (Csubi, [Cconst_int (m, _); c], _), Cconst_int (n, _)
+    when Misc.no_overflow_sub m n ->
+    (* [n = m - c] <=> [c = m - n]
+
+       This is typically generated by expressions of the form [if not expr then
+       ...], with [not expr] being compiled to [4 - c] and the condition for the
+       test becomes [1 = 4 - c].
+
+       We need to impose the side condition because the above equivalence hides
+       a subtlety: While [c] is a full-blooded native integer, [m] and [n] are
+       OCaml ints that will be sign-extended between now and run time. That in
+       itself doesn't break the equivalence. The problem is that we intend to
+       compute [m - n] right now, while [m] and [n] are one bit shorter. Thus
+       there's a bit of sleight of hand going on: the [m - n] we compute now may
+       not be the [m - n] that appears in the equivalence. [m - c], however,
+       _is_ subtraction of full native ints (it must be, since [c] can be any
+       native int). So [m - c] and [m - n] refer to two different operations and
+       we're cheekily swapping one for the other. We'll get away with it,
+       however, _so long as [m - n] doesn't overflow_.
+
+       Formally, writing [se] for sign extension, we can write a version of our
+       equivalence that's unconditionally true: [se(n) = se(m) - c] <=> [c =
+       se(m) - se(n)], where now [-] consistently means subtraction of native
+       ints. Effectively, we intend to write [c = se(m - n)] in the compiled
+       code (here [-] is instead subtraction of OCaml ints). This is the same as
+       [c = se(m) - se(n)] exactly when [se(m - n) = se(m) - se(n)], which is
+       another way of saying that [m - n] doesn't overflow.
+
+       The following z3 script confirms that this check is sufficient: *)
+    (*
+     *   (define-sort int63 () (_ BitVec 63))
+     *   (define-sort int64 () (_ BitVec 64))
+     *   (define-const z63 int63 ((_ int2bv 63) 0))
+     *
+     *   (declare-const m int63)
+     *   (declare-const n int63)
+     *   (declare-const c int64)
+     *
+     *   ; let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
+     *   (define-fun no_overflow_sub ((a int63) (b int63)) Bool
+     *     (bvslt (bvor (bvxor a (bvnot b)) (bvxor b (bvsub a b))) z63))
+     *
+     *   (assert (no_overflow_sub m n))
+     *
+     *   (assert (not (=
+     *     (= ((_ sign_extend 1) n) (bvsub ((_ sign_extend 1) m) c))
+     *     (= c ((_ sign_extend 1) (bvsub m n)))
+     *   )))
+     *
+     *   (check-sat)
+     *)
+    binary (Ccmpi Ceq) ~dbg c (Cconst_int (m - n, dbg))
+  | _, _ -> binary (Ccmpi Ceq) ~dbg x y
+
+let neq = binary (Ccmpi Cne)
+
+let lt = binary (Ccmpi Clt)
+
+let le = binary (Ccmpi Cle)
+
+let gt = binary (Ccmpi Cgt)
+
+let ge = binary (Ccmpi Cge)
+
+let ult = binary (Ccmpa Clt)
+
+let ule = binary (Ccmpa Cle)
+
+let ugt = binary (Ccmpa Cgt)
+
+let uge = binary (Ccmpa Cge)
+
+let float_abs = unary Cabsf
+
+let float_neg = unary Cnegf
+
+let float_add = binary Caddf
+
+let float_sub = binary Csubf
+
+let float_mul = binary Cmulf
+
+let float_div = binary Cdivf
+
+let float_eq = binary (Ccmpf CFeq)
+
+let float_neq = binary (Ccmpf CFneq)
+
+let float_lt = binary (Ccmpf CFlt)
+
+let float_le = binary (Ccmpf CFle)
+
+let float_gt = binary (Ccmpf CFgt)
+
+let float_ge = binary (Ccmpf CFge)
+
+let beginregion ~dbg = Cop (Cbeginregion, [], dbg)
+
+let endregion ~dbg region = Cop (Cendregion, [region], dbg)
+
+let probe ~dbg ~name ~handler_code_linkage_name ~args =
+  Cop (Cprobe { name; handler_code_sym = handler_code_linkage_name }, args, dbg)
+
+let load ~dbg kind mut ~addr = Cop (Cload (kind, mut), [addr], dbg)
+
+let store ~dbg kind init ~addr ~new_value =
+  Cop (Cstore (kind, init), [addr; new_value], dbg)
+
+let direct_call ~dbg ty f_code_sym args =
+  Cop (Capply (ty, Rc_normal), f_code_sym :: args, dbg)
+
+let indirect_call ~dbg ty alloc_mode f args =
+  match args with
+  | [arg] ->
+    (* Use a variable to avoid duplicating the cmm code of the closure [f]. *)
+    let v = Backend_var.create_local "*closure*" in
+    let v' = Backend_var.With_provenance.create v in
+    (* We always use [Rc_normal] since the [Lambda_to_flambda] pass has already
+       taken care of the placement of region begin/end primitives. *)
+    letin v' ~defining_expr:f
+      ~body:
+        (Cop
+           ( Capply (ty, Rc_normal),
+             [load ~dbg Word_int Asttypes.Mutable ~addr:(Cvar v); arg; Cvar v],
+             dbg ))
+  | args ->
+    let arity = List.length args in
+    let l =
+      (Cconst_symbol (apply_function_sym arity alloc_mode, dbg) :: args) @ [f]
+    in
+    Cop (Capply (ty, Rc_normal), l, dbg)
+
+let indirect_full_call ~dbg ty alloc_mode f = function
+  (* the single-argument case is already optimized by indirect_call *)
+  | [_] as args -> indirect_call ~dbg ty alloc_mode f args
+  | args ->
+    (* Use a variable to avoid duplicating the cmm code of the closure [f]. *)
+    let v = Backend_var.create_local "*closure*" in
+    let v' = Backend_var.With_provenance.create v in
+    (* get the function's code pointer *)
+    let fun_ptr =
+      load ~dbg Word_int Asttypes.Mutable ~addr:(field_address (Cvar v) 2 dbg)
+    in
+    letin v' ~defining_expr:f
+      ~body:(Cop (Capply (ty, Rc_normal), (fun_ptr :: args) @ [Cvar v], dbg))
+
+let extcall ~dbg ~returns ~alloc ~is_c_builtin ~ty_args name typ_res args =
+  if not returns then assert (typ_res = typ_void);
+  Cop
+    ( Cextcall
+        { func = name;
+          ty = typ_res;
+          alloc;
+          ty_args;
+          returns;
+          builtin = is_c_builtin;
+          effects = Arbitrary_effects;
+          coeffects = Has_coeffects
+        },
+      args,
+      dbg )
+
+let bigarray_load ~dbg ~elt_kind ~elt_size ~elt_chunk ~bigarray ~offset =
+  let ba_data_f = field_address bigarray 1 dbg in
+  let ba_data_p = load ~dbg Word_int Mutable ~addr:ba_data_f in
+  let addr =
+    array_indexing ~typ:Addr (Misc.log2 elt_size) ba_data_p offset dbg
+  in
+  match (elt_kind : Lambda.bigarray_kind) with
+  | Pbigarray_complex32 | Pbigarray_complex64 ->
+    let addr' = binary Cadda ~dbg addr (int ~dbg (elt_size / 2)) in
+    box_complex dbg
+      (load ~dbg elt_chunk Mutable ~addr)
+      (load ~dbg elt_chunk Mutable ~addr:addr')
+  | _ -> load ~dbg elt_chunk Mutable ~addr
+
+let bigarray_store ~dbg ~(elt_kind : Lambda.bigarray_kind) ~elt_size ~elt_chunk
+    ~bigarray ~offset ~new_value =
+  let ba_data_f = field_address bigarray 1 dbg in
+  let ba_data_p = load ~dbg Word_int Mutable ~addr:ba_data_f in
+  let addr =
+    array_indexing ~typ:Addr (Misc.log2 elt_size) ba_data_p offset dbg
+  in
+  match elt_kind with
+  | Pbigarray_complex32 | Pbigarray_complex64 ->
+    let addr' = binary Cadda ~dbg addr (int ~dbg (elt_size / 2)) in
+    return_unit dbg
+      (sequence
+         (store ~dbg elt_chunk Assignment ~addr
+            ~new_value:(complex_re new_value dbg))
+         (store ~dbg elt_chunk Assignment ~addr:addr'
+            ~new_value:(complex_im new_value dbg)))
+  | _ -> return_unit dbg (store ~dbg elt_chunk Assignment ~addr ~new_value)
+
+(* Infix field address. Contrary to regular field addresses, these addresses are
+   valid ocaml values, and can be live at gc points. *)
+
+let infix_field_address ~dbg ptr n =
+  if n = 0
+  then ptr
+  else Cmm.Cop (Cmm.Caddv, [ptr; int ~dbg (n * Arch.size_addr)], dbg)
+
+(* Data items *)
+
+let cint i = Cmm.Cint i
+
+let cfloat f = Cmm.Cdouble f
+
+let symbol_address s = Cmm.Csymbol_address s
+
+let define_symbol ~global s =
+  if global
+  then [Cmm.Cglobal_symbol s; Cmm.Cdefine_symbol s]
+  else [Cmm.Cdefine_symbol s]
+
+(* Cmm phrases *)
+
+let cfunction decl = Cmm.Cfunction decl
+
+let cdata d = Cmm.Cdata d
+
+let fundecl fun_name fun_args fun_body fun_codegen_options fun_dbg =
+  { Cmm.fun_name; fun_args; fun_body; fun_codegen_options; fun_dbg }
+
+(* Gc root table *)
+
+let gc_root_table ~make_symbol syms =
+  let table_symbol = make_symbol ?unitname:None (Some "gc_roots") in
+  cdata
+    (define_symbol ~global:true table_symbol
+    @ List.map symbol_address syms
+    @ [cint 0n])