remove clambda

Author: mshinwell

backend/cmm_helpers.ml

@@ -20,6 +20,12 @@ module VP = Backend_var.With_provenance
 open Cmm
 open Arch
 
+type arity =
+  { function_kind : Lambda.function_kind;
+    params_layout : Lambda.layout list;
+    return_layout : Lambda.layout
+  }
+
 (* Local binding of complex expressions *)
 
 let bind name arg fn =
@@ -151,7 +157,7 @@ let closure_info' ~arity ~startenv ~is_last =
   in
   pack_closure_info ~arity ~startenv ~is_last
 
-let closure_info ~(arity : Clambda.arity) ~startenv ~is_last =
+let closure_info ~(arity : arity) ~startenv ~is_last =
   closure_info'
     ~arity:(arity.function_kind, arity.params_layout)
     ~startenv ~is_last
@@ -717,7 +723,7 @@ let rec unbox_float dbg =
       c
     | Cconst_symbol (s, _dbg) as cmm -> (
       match Cmmgen_state.structured_constant_of_sym s.sym_name with
-      | Some (Uconst_float x) -> Cconst_float (x, dbg) (* or keep _dbg? *)
+      | Some (Const_float x) -> Cconst_float (x, dbg) (* or keep _dbg? *)
       | _ -> Cop (mk_load_immut Double, [cmm], dbg))
     | Cregion e as cmm -> (
       (* It is valid to push unboxing inside a Cregion except when the extra
@@ -749,7 +755,7 @@ let rec unbox_vec128 dbg =
       c
     | Cconst_symbol (s, _dbg) as cmm -> (
       match Cmmgen_state.structured_constant_of_sym s.sym_name with
-      | Some (Uconst_vec128 { low; high }) ->
+      | Some (Const_vec128 { low; high }) ->
         Cconst_vec128 ({ low; high }, dbg) (* or keep _dbg? *)
       | _ -> Cop (mk_load_immut Onetwentyeight_unaligned, [cmm], dbg))
     | Cregion e as cmm -> (
@@ -1653,11 +1659,11 @@ let rec unbox_int dbg bi =
       contents
     | Cconst_symbol (s, _dbg) as cmm -> (
       match Cmmgen_state.structured_constant_of_sym s.sym_name, bi with
-      | Some (Uconst_nativeint n), Primitive.Pnativeint ->
+      | Some (Const_nativeint n), Primitive.Pnativeint ->
         natint_const_untagged dbg n
-      | Some (Uconst_int32 n), Primitive.Pint32 ->
+      | Some (Const_int32 n), Primitive.Pint32 ->
         natint_const_untagged dbg (Nativeint.of_int32 n)
-      | Some (Uconst_int64 n), Primitive.Pint64 ->
+      | Some (Const_int64 n), Primitive.Pint64 ->
         natint_const_untagged dbg (Int64.to_nativeint n)
       | _ -> default cmm)
     | Cregion e as cmm -> (

backend/cmm_helpers.mli

@@ -15,6 +15,12 @@
 
 open Cmm
 
+type arity =
+  { function_kind : Lambda.function_kind;
+    params_layout : Lambda.layout list;
+    return_layout : Lambda.layout
+  }
+
 (** [bind name arg fn] is equivalent to [let name = arg in fn name], or simply
     [fn arg] if [arg] is simple enough *)
 val bind : string -> expression -> (expression -> expression) -> expression
@@ -60,8 +66,7 @@ val boxedint64_header : nativeint
 val boxedintnat_header : nativeint
 
 (** Closure info for a closure of given arity and distance to environment *)
-val closure_info :
-  arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint
+val closure_info : arity:arity -> startenv:int -> is_last:bool -> nativeint
 
 val closure_info' :
   arity:Lambda.function_kind * 'a list ->
@@ -73,11 +78,7 @@ val closure_info' :
 val alloc_infix_header : int -> Debuginfo.t -> expression
 
 val alloc_closure_info :
-  arity:Clambda.arity ->
-  startenv:int ->
-  is_last:bool ->
-  Debuginfo.t ->
-  expression
+  arity:arity -> startenv:int -> is_last:bool -> Debuginfo.t -> expression
 
 (** Integers *)
 

backend/cmmgen_state.ml

@@ -19,14 +19,93 @@
 
 module S = Misc.Stdlib.String
 
+type ustructured_constant =
+  | Const_float of float
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+  | Const_vec128 of { high : int64; low : int64 }
+  | Const_block of int * uconstant list
+  | Const_float_array of float list
+  | Const_string of string
+
+and uconstant =
+  | Const_ref of string * ustructured_constant option
+  | Const_int of int
+
+(* Comparison functions for constants.  We must not use Stdlib.compare
+   because it compares "0.0" and "-0.0" equal.  (PR#6442) *)
+
+let compare_floats x1 x2 =
+  Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
+
+let rec compare_float_lists l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _::_ -> -1
+  | _::_, [] -> 1
+  | h1::t1, h2::t2 ->
+      let c = compare_floats h1 h2 in
+      if c <> 0 then c else compare_float_lists t1 t2
+
+let compare_constants c1 c2 =
+  match c1, c2 with
+  | Const_ref(lbl1, _c1), Const_ref(lbl2, _c2) -> String.compare lbl1 lbl2
+      (* Same labels -> same constants.
+         Different labels -> different constants, even if the contents
+           match, because of string constants that must not be
+           reshared. *)
+  | Const_int n1, Const_int n2 -> Stdlib.compare n1 n2
+  | Const_ref _, _ -> -1
+  | Const_int _, Const_ref _ -> 1
+
+let rec compare_constant_lists l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _::_ -> -1
+  | _::_, [] -> 1
+  | h1::t1, h2::t2 ->
+      let c = compare_constants h1 h2 in
+      if c <> 0 then c else compare_constant_lists t1 t2
+
+let rank_structured_constant = function
+  | Const_float _ -> 0
+  | Const_int32 _ -> 1
+  | Const_int64 _ -> 2
+  | Const_nativeint _ -> 3
+  | Const_block _ -> 4
+  | Const_float_array _ -> 5
+  | Const_string _ -> 6
+  | Const_vec128 _ -> 8
+
+let compare_structured_constants c1 c2 =
+  match c1, c2 with
+  | Const_float x1, Const_float x2 -> compare_floats x1 x2
+  | Const_int32 x1, Const_int32 x2 -> Int32.compare x1 x2
+  | Const_int64 x1, Const_int64 x2 -> Int64.compare x1 x2
+  | Const_nativeint x1, Const_nativeint x2 -> Nativeint.compare x1 x2
+  | Const_block(t1, l1), Const_block(t2, l2) ->
+      let c = t1 - t2 (* no overflow possible here *) in
+      if c <> 0 then c else compare_constant_lists l1 l2
+  | Const_float_array l1, Const_float_array l2 ->
+      compare_float_lists l1 l2
+  | Const_string s1, Const_string s2 -> String.compare s1 s2
+  | Const_vec128 { high = l0; low = l1},
+    Const_vec128 { high = r0; low = r1} ->
+    let cmp = Int64.compare l0 r0 in
+    if cmp = 0 then Int64.compare l1 r1 else cmp
+  | _, _ ->
+    (* no overflow possible here *)
+    rank_structured_constant c1 - rank_structured_constant c2
+
 type constant =
   | Const_table of Cmm.is_global * Cmm.data_item list
 
 type t = {
   mutable constants : constant S.Map.t;
   mutable data_items : Cmm.data_item list list;
   structured_constants :
-    (string, Cmm.is_global * Clambda.ustructured_constant) Hashtbl.t;
+    (string, Cmm.is_global * ustructured_constant) Hashtbl.t;
 }
 
 let empty = {

backend/cmmgen_state.mli

@@ -19,6 +19,27 @@
 
 [@@@ocaml.warning "+a-4-30-40-41-42"]
 
+type ustructured_constant =
+  | Const_float of float
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+  | Const_vec128 of { high : int64; low : int64 }
+  | Const_block of int * uconstant list
+  | Const_float_array of float list
+  | Const_string of string
+
+and uconstant =
+  | Const_ref of string * ustructured_constant option
+  | Const_int of int
+
+(* Comparison functions for constants *)
+
+val compare_structured_constants:
+        ustructured_constant -> ustructured_constant -> int
+val compare_constants:
+        uconstant -> uconstant -> int
+
 type constant =
   | Const_table of Cmm.is_global * Cmm.data_item list
 
@@ -30,12 +51,12 @@ val get_and_clear_constants : unit -> constant Misc.Stdlib.String.Map.t
 
 val get_and_clear_data_items : unit -> Cmm.data_item list
 
-val add_structured_constant : Cmm.symbol -> Clambda.ustructured_constant -> unit
+val add_structured_constant : Cmm.symbol -> ustructured_constant -> unit
 
 val clear_local_structured_constants : unit -> unit
 
-val add_global_structured_constant : string -> Clambda.ustructured_constant -> unit
+val add_global_structured_constant : string -> ustructured_constant -> unit
 
-val get_structured_constant : string -> (Cmm.is_global * Clambda.ustructured_constant) option
+val get_structured_constant : string -> (Cmm.is_global * ustructured_constant) option
 
-val structured_constant_of_sym : string -> Clambda.ustructured_constant option
+val structured_constant_of_sym : string -> ustructured_constant option

dune

@@ -75,7 +75,6 @@
   cmxs_format
   ;; middle_end/
   backend_var
-  clambda
   compilenv
   ;; asmcomp/
   afl_instrument