Rec_info: Add coercions

compilerlibs/Makefile.compilerlibs

@@ -189,6 +189,7 @@ MIDDLE_END_FLAMBDA_COMPILENV_DEPS=\
   middle_end/flambda/compilenv_deps/flambda_colours.cmo \
   middle_end/flambda/compilenv_deps/compilation_unit.cmo \
   middle_end/flambda/compilenv_deps/rec_info.cmo \
+  middle_end/flambda/compilenv_deps/coercion.cmo \
   middle_end/flambda/compilenv_deps/reg_width_things.cmo \
   middle_end/flambda/compilenv_deps/symbol.cmo \
   middle_end/flambda/compilenv_deps/variable.cmo \

middle_end/flambda/basic/simple.ml

@@ -53,25 +53,30 @@ let pattern_match' t ~var ~symbol ~const =
 
 let const_from_descr descr = const (RWC.of_descr descr)
 
-let without_rec_info t = pattern_match t ~name ~const
+let without_coercion t = pattern_match t ~name ~const
 
-let merge_rec_info t ~newer_rec_info =
-  if is_const t then None
+let apply_coercion t applied_coercion =
+  if Coercion.is_id applied_coercion then Some t
   else
-    match newer_rec_info with
-    | None -> Some t
-    | Some newer_rec_info ->
-      let rec_info =
-        match rec_info t with
-        | None -> newer_rec_info
-        | Some older_rec_info ->
-          Rec_info.merge older_rec_info ~newer:newer_rec_info
-      in
-      Some (with_rec_info (without_rec_info t) rec_info)
+    let coercion = 
+      let existing_coercion = coercion t in
+      if Coercion.is_id existing_coercion then Some applied_coercion
+      else Coercion.compose existing_coercion ~then_:applied_coercion
+    in
+    coercion
+    |> Option.map (fun coercion -> with_coercion (without_coercion t) coercion)
+
+let apply_coercion_exn t applied_coercion =
+  match apply_coercion t applied_coercion with
+  | Some t -> t
+  | None ->
+    Misc.fatal_errorf "Cannot apply coercion %a to %a"
+      print t
+      Coercion.print applied_coercion
 
 (* CR mshinwell: Make naming consistent with [Name] re. the option type *)
 
-(* CR mshinwell: Careful that Rec_info doesn't get dropped using the
+(* CR mshinwell: Careful that coercions don't get dropped using the
    following *)
 
 let [@inline always] must_be_var t =
@@ -86,7 +91,7 @@ let [@inline always] must_be_name t =
 let to_name t =
   match must_be_name t with
   | None -> None
-  | Some name -> Some (rec_info t, name)
+  | Some name -> Some (coercion t, name)
 
 let map_name t ~f =
   match must_be_name t with
@@ -118,9 +123,7 @@ let apply_name_permutation t perm =
     let new_name = Name_permutation.apply_name perm old_name in
     if old_name == new_name then t
     else
-      match rec_info t with
-      | None -> name new_name
-      | Some rec_info -> with_rec_info (name new_name) rec_info
+      with_coercion (name new_name) (coercion t)
   in
   pattern_match t ~const:(fun _ -> t) ~name
 

middle_end/flambda/basic/simple.mli

@@ -23,9 +23,11 @@ include module type of struct include Reg_width_things.Simple end
 
 include Contains_names.S with type t := t
 
-val merge_rec_info : t -> newer_rec_info:Rec_info.t option -> t option
+val apply_coercion : t -> Coercion.t -> t option
 
-val without_rec_info : t -> t
+val apply_coercion_exn : t -> Coercion.t -> t
+
+val without_coercion : t -> t
 
 val must_be_var : t -> Variable.t option
 
@@ -64,7 +66,7 @@ val const_from_descr : Reg_width_const.Descr.t -> t
 
 val map_name : t -> f:(Name.t -> Name.t) -> t
 
-val to_name : t -> (Rec_info.t option * Name.t) option
+val to_name : t -> (Coercion.t * Name.t) option
 
 (* CR mshinwell: remove these next two? *)
 val map_var : t -> f:(Variable.t -> Variable.t) -> t

middle_end/flambda/cmx/ids_for_export.ml

@@ -74,9 +74,9 @@ let add_name t name =
 
 let add_simple t simple =
   let simples =
-    match Simple.rec_info simple with
-    | None -> t.simples
-    | Some _ -> Simple.Set.add simple t.simples
+    match Simple.coercion simple with
+    | Id -> t.simples
+    | _ -> Simple.Set.add simple t.simples
   in
   let t = { t with simples; } in
   Simple.pattern_match simple
@@ -91,11 +91,11 @@ let add_continuation t continuation =
 
 let from_simple simple =
   let simples =
-    match Simple.rec_info simple with
-    | None ->
+    match Simple.coercion simple with
+    | Id ->
       (* This simple will not be in the grand_table_of_simples *)
       Simple.Set.empty
-    | Some _ -> Simple.Set.singleton simple
+    | _ -> Simple.Set.singleton simple
   in
   Simple.pattern_match simple
     ~const:(fun const ->
@@ -199,12 +199,12 @@ module Import_map = struct
     match Simple.Map.find simple t.simples with
     | simple -> simple
     | exception Not_found ->
-      begin match Simple.rec_info simple with
-      | None ->
+      begin match Simple.coercion simple with
+      | Id ->
         Simple.pattern_match simple
           ~name:(fun n -> Simple.name (name t n))
           ~const:(fun c -> Simple.const (const t c))
-      | Some _rec_info -> simple
+      | _ -> simple
       end
 
   let closure_var_is_used t var =

middle_end/flambda/compilenv_deps/coercion.ml

@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Mark Shinwell, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Id
+  | Non_id of {
+      from_depth : int;
+      to_depth : int;
+    }
+
+let id = Id
+
+let change_depth ~from:from_depth ~to_:to_depth =
+  if from_depth = to_depth then Id else Non_id { from_depth; to_depth }
+
+let is_id = function
+  | Id -> true
+  | Non_id _ -> false
+
+let inverse = function
+  | Id -> Id
+  | Non_id { from_depth; to_depth } ->
+    Non_id { from_depth = to_depth; to_depth = from_depth }
+
+let print ppf = function
+  | Id ->
+    Format.fprintf ppf "@<0>%sid@<0>%s"
+      (Flambda_colours.elide ())
+      (Flambda_colours.normal ())
+  | Non_id { from_depth; to_depth; } ->
+    Format.fprintf ppf "@<0>%s@[<hov 1>(depth@ %d ->@ %d)@]@<0>%s"
+      (Flambda_colours.coercion ())
+      from_depth to_depth
+      (Flambda_colours.normal ())
+
+let compose t1 ~then_:t2 =
+  match t1, t2 with
+  | Id, _ -> Some t2
+  | _, Id -> Some t1
+  | Non_id { from_depth = from_depth1; to_depth = to_depth1 },
+    Non_id { from_depth = from_depth2; to_depth = to_depth2 } ->
+    if to_depth1 = from_depth2 then
+      Some (change_depth ~from:from_depth1 ~to_:to_depth2)
+    else
+      None
+
+let compose_exn t1 ~then_:t2 =
+  match compose t1 ~then_:t2 with
+  | Some t -> t
+  | None ->
+    Misc.fatal_errorf "Invalid composition: %a@ >>@ %a" print t1 print t2
+
+let equal t1 t2 =
+  match t1, t2 with
+  | Id, Id -> true
+  | Non_id { from_depth = from_depth1; to_depth = to_depth1 },
+    Non_id { from_depth = from_depth2; to_depth = to_depth2 } ->
+    from_depth1 = from_depth2 && to_depth1 = to_depth2
+  | _, _ -> false
+
+let hash = Hashtbl.hash
+
+let apply_to_rec_info _ rec_info = rec_info

middle_end/flambda/compilenv_deps/coercion.mli

@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Mark Shinwell, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-30-40-41-42"]
+
+type t = private
+  | Id
+  | Non_id of {
+      from_depth : int;
+      to_depth : int;
+    }
+
+val change_depth : from:int -> to_:int -> t
+
+val id : t
+val is_id : t -> bool
+val inverse : t -> t
+val compose : t -> then_:t -> t option
+val compose_exn : t -> then_:t -> t
+val print : Format.formatter -> t -> unit
+val equal : t -> t -> bool
+val hash : t -> int
+
+val apply_to_rec_info : t -> Rec_info.t -> Rec_info.t

middle_end/flambda/compilenv_deps/flambda_colours.ml

@@ -55,7 +55,9 @@ let continuation_annotation () = (C.fg_256 202) ^ (C.bg_256 237)
 
 let name_abstraction () = C.fg_256 172
 
-let rec_info () = C.fg_256 243
+let rec_info () = C.fg_256 249
+
+let coercion () = C.fg_256 243
 
 let error () = C.fg_256 160
 

middle_end/flambda/compilenv_deps/flambda_colours.mli

@@ -55,6 +55,8 @@ val name_abstraction : unit -> string
 
 val rec_info : unit -> string
 
+val coercion : unit -> string
+
 val elide : unit -> string
 
 val error : unit -> string

middle_end/flambda/compilenv_deps/rec_info.ml

@@ -13,54 +13,25 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-30-40-41-42"]
-
-type t = {
-  depth : int;
-  unroll_to : int option;
-}
+type t = unit
 
 include Identifiable.Make (struct
   type nonrec t = t
 
-  let print ppf { depth; unroll_to; } =
-    Format.fprintf ppf "%s@[<hov 1>(\
-        @[<hov 1>(depth@ %d)@]@ \
-        @[<hov 1>(unroll_to@ %a)@]\
-        )@]%s"
-      (Flambda_colours.rec_info ())
-      depth
-      (Misc.Stdlib.Option.print Numbers.Int.print) unroll_to
-      (Flambda_colours.normal ())
+  let print ppf () =
+    Format.fprintf ppf "@<0>%s()@<0>%s"
+    (Flambda_colours.rec_info ())
+    (Flambda_colours.normal ())
 
-  let compare t1 t2 = Stdlib.compare t1 t2
+  let compare () () = 0
 
-  let equal t1 t2 = (compare t1 t2 = 0)
+  let equal () () = true
 
-  let hash t = Hashtbl.hash t
+  let hash () = Hashtbl.hash ()
 
   let output _ _ = Misc.fatal_error "Not yet implemented"
 end)
 
-let create ~depth ~unroll_to =
-  { depth;
-    unroll_to;
-  }
-
-let depth t = t.depth
-let unroll_to t = t.unroll_to
-
-let merge { depth = depth1; unroll_to = older_unroll_to; } ~newer =
-  let { depth = depth2; unroll_to = newer_unroll_to; } = newer in
-  let depth = depth1 + depth2 in
-  let unroll_to =
-    match newer_unroll_to with
-    | Some _ -> newer_unroll_to
-    | None -> older_unroll_to
-  in
-  { depth;
-    unroll_to;
-  }
-
-let initial = create ~depth:0 ~unroll_to:None
+let initial = ()
 
-let is_initial t = equal t initial
+let is_initial () = true

middle_end/flambda/compilenv_deps/rec_info.mli

@@ -13,19 +13,11 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-30-40-41-42"]
-
-type t
+type t = unit
 
 include Identifiable.S with type t := t
 
-val create : depth:int -> unroll_to:int option -> t
-
-val depth : t -> int
-
-val unroll_to : t -> int option
-
-val merge : t -> newer:t -> t
-
 val initial : t
 
 val is_initial : t -> bool
+