Tweak to symbol projection meet

Makefile

@@ -278,7 +278,8 @@ MIDDLE_END_FLAMBDA_BASIC=\
   middle_end/flambda/basic/apply_cont_rewrite_id.cmo \
   middle_end/flambda/basic/continuation_extra_params_and_args.cmo \
   middle_end/flambda/basic/symbol_scoping_rule.cmo \
-  middle_end/flambda/basic/or_deleted.cmo
+  middle_end/flambda/basic/or_deleted.cmo \
+  middle_end/flambda/terms/symbol_projection.cmo
 
 MIDDLE_END_FLAMBDA_NAMING=\
   middle_end/flambda/naming/contains_names.cmo \

flambdatest/mlexamples/int32.ml

@@ -111,7 +111,7 @@ external ( asr ) : int -> int -> int = "%asrint"
 
 let max_int = (-1) lsr 1
 let min_int = max_int + 1
-
+(*
 (* Floating-point operations *)
 
 external ( ~-. ) : float -> float = "%negfloat"
@@ -260,8 +260,9 @@ let bool_of_string_opt = function
 
 let string_of_int n =
   format_int "%d" n
-
+*)
 external int_of_string : string -> int = "caml_int_of_string"
+(*
 
 let int_of_string_opt s =
   (* TODO: provide this directly as a non-raising primitive. *)
@@ -561,7 +562,7 @@ let exit retcode =
   sys_exit retcode
 
 let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
-
+*)
 end
 
 open Stdlib
@@ -619,7 +620,7 @@ let unsigned_to_int =
       fun n -> let i = to_int n in Some (if i < 0 then i + move else i)
   | _ ->
       assert false
-
+(*
 external format : string -> int32 -> string = "caml_int32_format"
 let to_string n = format "%d" n
 
@@ -651,3 +652,4 @@ let unsigned_div n d =
 
 let unsigned_rem n d =
   sub n (mul (unsigned_div n d) d)
+*)

flambdatest/mlexamples/protect_refs.ml

@@ -0,0 +1,30 @@
+let rec iter f = function
+    [] -> ()
+  | a::l -> f a; iter f l
+
+type 'a ref = { mutable contents : 'a; }
+external ref : 'a -> 'a ref = "%makemutable"
+external ( ! ) : 'a ref -> 'a = "%field0"
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+external raise : exn -> 'a = "%raise"
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    set_refs refs;
+    f ()
+
+type unification_mode =
+  | Expression
+  | Pattern
+
+let umode = ref Expression
+
+let[@inline never] set_mode_pattern f =
+  protect_refs
+    [R (umode, Pattern)] f
+
+let () =
+  set_mode_pattern (fun () -> ())

flambdatest/mlexamples/symbol_projections.ml

@@ -0,0 +1,14 @@
+external getenv : string -> string = "caml_sys_getenv"
+external (+) : int -> int -> int = "%addint"
+
+let foo =
+  match getenv "FOO" with
+  | exception _ -> false
+  | _ -> true
+
+let f x =
+  let g y =
+    if foo then y + y
+    else y
+  in
+  x, g

flambdatest/mlexamples/symbol_projections2.ml

@@ -0,0 +1,12 @@
+(* From pchambart 2020-07-22, ocaml-flambda/ocaml issue #214 *)
+
+external opaque_identity : 'a -> 'a = "%opaque"
+external (+) : int -> int -> int = "%addint"
+let[@inline never] ignore _ = ()
+
+let v = opaque_identity 33
+
+let g () =
+  let () = ignore () in
+  let f x = x + v in
+  f

flambdatest/mlexamples/symbol_projections3.ml

@@ -0,0 +1,15 @@
+external getenv : string -> string = "caml_sys_getenv"
+external (+) : int -> int -> int = "%addint"
+
+let foo =
+  match getenv "FOO" with
+  | exception _ -> false
+  | _ -> true
+
+let f x =
+  let g y =
+    if foo then y + y
+    else y
+  in
+  let block_to_lift = foo, foo in
+  x, g, block_to_lift

flambdatest/mlexamples/symbol_projections4.ml

@@ -0,0 +1,21 @@
+external getenv : string -> string = "caml_sys_getenv"
+external (+) : int -> int -> int = "%addint"
+
+let foo =
+  match getenv "FOO" with
+  | exception _ -> false
+  | _ -> true
+
+let f x b =
+  if b then
+    let g y =
+      if foo then y + y
+      else y
+    in
+    x, g
+  else
+    let h y =
+      if foo then y + y + y
+      else y
+    in
+    x, h

flambdatest/mlexamples/symbol_projections5.ml

@@ -0,0 +1,27 @@
+external getenv : string -> string = "caml_sys_getenv"
+external (+) : int -> int -> int = "%addint"
+external (<) : int -> int -> bool = "%lessthan"
+external (&&) : bool -> bool -> bool = "%logand"
+
+let foo =
+  match getenv "FOO" with
+  | exception _ -> false
+  | _ -> true
+
+type t =
+  | S of (int -> t)
+  | T of (int -> t)
+
+let f b =
+  if b then
+    let rec g y =
+      if y < 0 then S g
+      else T g
+    in
+    g
+  else
+    let rec h z =
+      if z < 0 then S h
+      else T h
+    in
+    h

flambdatest/mlexamples/symbol_projections6.ml

@@ -0,0 +1,27 @@
+external getenv : string -> string = "caml_sys_getenv"
+external (+) : int -> int -> int = "%addint"
+external (<) : int -> int -> bool = "%lessthan"
+external (&&) : bool -> bool -> bool = "%sequand"
+
+let foo =
+  match getenv "FOO" with
+  | exception _ -> false
+  | _ -> true
+
+type t =
+  | S of (int -> (t * bool))
+  | T of (int -> (t * bool))
+
+let f b =
+  if b then
+    let rec g y =
+      if y < 0 && foo then S g, foo
+      else T g, foo
+    in
+    g
+  else
+    let rec h z =
+      if z < 0 && foo then S h, foo
+      else T h, foo
+    in
+    h

flambdatest/mlexamples/symbol_projections7.ml

@@ -0,0 +1,11 @@
+external word_size : unit -> int = "%word_size"
+external (+) : int -> int -> int = "%addint"
+external opaque : 'a -> 'a = "%opaque"
+let foo =
+  match word_size () with
+  | 32 -> (fun x -> x + 1)
+  | 64 ->
+    let y = opaque 2 in
+    (fun x -> x + y)
+  | _ ->
+      assert false

middle_end/flambda/basic/mutability.ml

@@ -50,3 +50,8 @@ let to_lambda t : Asttypes.mutable_flag =
   | Mutable -> Mutable
   | Immutable -> Immutable
   | Immutable_unique -> Immutable
+
+let is_mutable t =
+  match t with
+  | Mutable -> true
+  | Immutable | Immutable_unique -> false

middle_end/flambda/basic/mutability.mli

@@ -31,3 +31,5 @@ val compare : t -> t -> int
 val join : t -> t -> t
 
 val to_lambda : t -> Asttypes.mutable_flag
+
+val is_mutable : t -> bool

middle_end/flambda/basic/simple.ml

@@ -47,6 +47,10 @@ let [@inline always] is_symbol t =
 let [@inline always] is_const t =
   pattern_match t ~name:(fun _ -> false) ~const:(fun _ -> true)
 
+let pattern_match' t ~var ~symbol ~const =
+  pattern_match t ~const
+    ~name:(fun name -> Name.pattern_match name ~var ~symbol)
+
 let const_from_descr descr = const (RWC.of_descr descr)
 
 let without_rec_info t = pattern_match t ~name ~const

middle_end/flambda/basic/simple.mli

@@ -78,6 +78,13 @@ val is_var : t -> bool
 
 val free_names_in_types : t -> Name_occurrences.t
 
+val pattern_match'
+   : t
+  -> var:(Variable.t -> 'a)
+  -> symbol:(Symbol.t -> 'a)
+  -> const:(Reg_width_const.t -> 'a)
+  -> 'a
+
 module List : sig
   type nonrec t = t list
 

middle_end/flambda/compilenv_deps/reg_width_things.mli

@@ -164,9 +164,9 @@ module Simple : sig
     -> const:(Const.t -> 'a)
     -> 'a
 
-   (* [same s1 s2] returns true iff they represent the same name or const
-      i.e. [same s (with_rec_info s rec_info)] returns true *)
-   val same : t -> t -> bool
+  (* [same s1 s2] returns true iff they represent the same name or const
+     i.e. [same s (with_rec_info s rec_info)] returns true *)
+  val same : t -> t -> bool
 
   val export : t -> exported
 

middle_end/flambda/lifting/lift_inconstants.ml

@@ -34,6 +34,7 @@ let reify_primitive_at_toplevel dacc bound_var ty =
      the [is_fully_static] check below. *)
   match
     T.reify ~allowed_if_free_vars_defined_in:typing_env
+      ~additional_free_var_criterion:(DE.is_defined_at_toplevel (DA.denv dacc))
       ~allow_unique:true
       typing_env ~min_name_mode:NM.normal ty
   with

middle_end/flambda/lifting/reification.ml

@@ -61,9 +61,26 @@ let lift dacc ty ~bound_to static_const =
         Misc.fatal_errorf "Cannot lift non-[Value] variable: %a"
           Variable.print bound_to
       end;
+      let symbol_projections =
+        Name_occurrences.fold_variables (Static_const.free_names static_const)
+          ~init:Variable.Map.empty
+          ~f:(fun symbol_projections var ->
+            match DE.find_symbol_projection (DA.denv dacc) var with
+            | None -> symbol_projections
+            | Some proj -> Variable.Map.add var proj symbol_projections)
+      in
+      (*
+      if not (Variable.Map.is_empty symbol_projections) then begin
+        Format.eprintf "\nConstant:@ %a@ Symbol projections when created:@ %a\n%!"
+          Static_const.print static_const
+          (Variable.Map.print Symbol_projection.print) symbol_projections
+      end;
+      *)
       let dacc =
         let denv = DA.denv dacc in
-        Lifted_constant.create_block_like symbol static_const denv ty
+        Lifted_constant.create_block_like symbol static_const denv
+          ~symbol_projections
+          ty
         |> DA.add_lifted_constant dacc
       in
       let dacc =
@@ -92,7 +109,16 @@ let try_to_reify dacc (term : Reachable.t) ~bound_to ~allow_lifting =
     let denv = DE.add_equation_on_variable denv bound_to ty in
     Reachable.invalid (), DA.with_denv dacc denv, ty
   | Reachable _ ->
-    match T.reify (DE.typing_env denv) ~min_name_mode:occ_kind ty with
+    let typing_env = DE.typing_env denv in
+    let reify_result =
+      T.reify ~allowed_if_free_vars_defined_in:typing_env
+        ~additional_free_var_criterion:(fun var ->
+          DE.is_defined_at_toplevel denv var
+            || Option.is_some (DE.find_symbol_projection denv var))
+        ~allow_unique:true
+        typing_env ~min_name_mode:NM.normal ty
+    in
+    match reify_result with
     | Lift to_lift ->
       if Name_mode.is_normal occ_kind && allow_lifting then
         let static_const = create_static_const to_lift in

middle_end/flambda/lifting/sort_lifted_constants.ml

@@ -30,12 +30,10 @@ let build_dep_graph lifted_constants =
         ~f:(fun (dep_graph, code_id_or_symbol_to_const) definition ->
           let module D = LC.Definition in
           let free_names =
-            let free_names =
-              Static_const.free_names (D.defining_expr definition)
-            in
+            let free_names = D.free_names definition in
             match D.descr definition with
             | Code _ | Block_like _ -> free_names
-            | Set_of_closures { denv = _; closure_symbols_with_types; } ->
+            | Set_of_closures { closure_symbols_with_types; _; } ->
               (* To avoid existing sets of closures (with or without associated
                  code) being pulled apart, we add a dependency from each of the
                  closure symbols (in the current set) to all of the others