Merge pull request #10090 from Keryan-dev/mutvar

Distinguished lambda constructors for ref variables

Changes

@@ -96,11 +96,13 @@ Working version
   changes in the parser.
   (François Pottier, review by Gabriel Scherer and Xavier Leroy.)
 
+- #10090: Distinguished constructors for ref variables at lambda level
+  (Keryan Didier, review by Gabriel Scherer and Vincent Laviron)
+
 - #10113: add a `-timeout` option to ocamltest and use it in the test suite.
   (Xavier Leroy and Gabriel Scherer, review by Sébastien Hinderer
    and David Allsopp)
 
-
 ### Build system:
 
 - #9191, #10091: take the LDFLAGS variable into account, except on

bytecomp/bytegen.ml

@@ -524,7 +524,7 @@ module Storer =
 let rec comp_expr env exp sz cont =
   if sz > !max_stack_used then max_stack_used := sz;
   match exp with
-    Lvar id ->
+    Lvar id | Lmutvar id ->
       begin try
         let pos = Ident.find_same id env.ce_stack in
         Kacc(sz - pos) :: cont
@@ -591,7 +591,8 @@ let rec comp_expr env exp sz cont =
       Stack.push to_compile functions_to_compile;
       comp_args env (List.map (fun n -> Lvar n) fv) sz
         (Kclosure(lbl, List.length fv) :: cont)
-  | Llet(_str, _k, id, arg, body) ->
+  | Llet(_, _k, id, arg, body)
+  | Lmutlet(_k, id, arg, body) ->
       comp_expr env arg sz
         (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
           (add_pop 1 cont))

lambda/lambda.ml

@@ -259,7 +259,7 @@ type local_attribute =
 
 type function_kind = Curried | Tupled
 
-type let_kind = Strict | Alias | StrictOpt | Variable
+type let_kind = Strict | Alias | StrictOpt
 
 type meth_kind = Self | Public | Cached
 
@@ -284,10 +284,12 @@ type scoped_location = Debuginfo.Scoped_location.t
 
 type lambda =
     Lvar of Ident.t
+  | Lmutvar of Ident.t
   | Lconst of structured_constant
   | Lapply of lambda_apply
   | Lfunction of lfunction
   | Llet of let_kind * value_kind * Ident.t * lambda * lambda
+  | Lmutlet of value_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list * scoped_location
   | Lswitch of lambda * lambda_switch * scoped_location
@@ -382,7 +384,8 @@ let make_key e =
     incr count ;
     if !count > max_raw then raise Not_simple ; (* Too big ! *)
     match e with
-    | Lvar id ->
+    | Lvar id
+    | Lmutvar id ->
       begin
         try Ident.find_same id env
         with Not_found -> e
@@ -405,6 +408,10 @@ let make_key e =
         let ex = tr_rec env ex in
         let y = make_key x in
         Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
+    | Lmutlet (k,x,ex,e) ->
+        let ex = tr_rec env ex in
+        let y = make_key x in
+        Lmutlet (k,y,ex,tr_rec (Ident.add x (Lmutvar y) env) e)
     | Lprim (p,es,_) ->
         Lprim (p,tr_recs env es, Loc_unknown)
     | Lswitch (e,sw,loc) ->
@@ -479,12 +486,14 @@ let iter_opt f = function
 
 let shallow_iter ~tail ~non_tail:f = function
     Lvar _
+  | Lmutvar _
   | Lconst _ -> ()
   | Lapply{ap_func = fn; ap_args = args} ->
       f fn; List.iter f args
   | Lfunction{body} ->
       f body
-  | Llet(_str, _k, _id, arg, body) ->
+  | Llet(_, _k, _id, arg, body)
+  | Lmutlet(_k, _id, arg, body) ->
       f arg; tail body
   | Lletrec(decl, body) ->
       tail body;
@@ -533,14 +542,16 @@ let iter_head_constructor f l =
   shallow_iter ~tail:f ~non_tail:f l
 
 let rec free_variables = function
-  | Lvar id -> Ident.Set.singleton id
+  | Lvar id
+  | Lmutvar id -> Ident.Set.singleton id
   | Lconst _ -> Ident.Set.empty
   | Lapply{ap_func = fn; ap_args = args} ->
       free_variables_list (free_variables fn) args
   | Lfunction{body; params} ->
       Ident.Set.diff (free_variables body)
         (Ident.Set.of_list (List.map fst params))
-  | Llet(_str, _k, id, arg, body) ->
+  | Llet(_, _k, id, arg, body)
+  | Lmutlet(_k, id, arg, body) ->
       Ident.Set.union
         (free_variables arg)
         (Ident.Set.remove id (free_variables body))
@@ -715,6 +726,14 @@ let subst update_env ?(freshen_bound_variables = false) s input_lam =
                 to [l]; it is a free variable of the input term. *)
              begin try Ident.Map.find id s with Not_found -> lam end
         end
+    | Lmutvar id as lam ->
+       begin match Ident.Map.find id l with
+          | id' -> Lmutvar id'
+          | exception Not_found ->
+             (* Note: a mutable [id] should not appear in [s].
+                Keeping the behavior of Lvar case for now. *)
+             begin try Ident.Map.find id s with Not_found -> lam end
+        end
     | Lconst _ as l -> l
     | Lapply ap ->
         Lapply{ap with ap_func = subst s l ap.ap_func;
@@ -725,6 +744,9 @@ let subst update_env ?(freshen_bound_variables = false) s input_lam =
     | Llet(str, k, id, arg, body) ->
         let id, l' = bind id l in
         Llet(str, k, id, subst s l arg, subst s l' body)
+    | Lmutlet(k, id, arg, body) ->
+        let id, l' = bind id l in
+        Lmutlet(k, id, subst s l arg, subst s l' body)
     | Lletrec(decl, body) ->
         let decl, l' = bind_many decl l in
         Lletrec(List.map (subst_decl s l') decl, subst s l' body)
@@ -818,6 +840,7 @@ let duplicate lam =
 
 let shallow_map f = function
   | Lvar _
+  | Lmutvar _
   | Lconst _ as lam -> lam
   | Lapply { ap_func; ap_args; ap_loc; ap_tailcall;
              ap_inlined; ap_specialised } ->
@@ -833,6 +856,8 @@ let shallow_map f = function
       Lfunction { kind; params; return; body = f body; attr; loc; }
   | Llet (str, k, v, e1, e2) ->
       Llet (str, k, v, f e1, f e2)
+  | Lmutlet (k, v, e1, e2) ->
+      Lmutlet (k, v, f e1, f e2)
   | Lletrec (idel, e2) ->
       Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2)
   | Lprim (p, el, loc) ->

lambda/lambda.mli

@@ -234,7 +234,7 @@ type local_attribute =
 
 type function_kind = Curried | Tupled
 
-type let_kind = Strict | Alias | StrictOpt | Variable
+type let_kind = Strict | Alias | StrictOpt
 (* Meaning of kinds for let x = e in e':
     Strict: e may have side-effects; always evaluate e first
       (If e is a simple expression, e.g. a variable or constant,
@@ -243,7 +243,6 @@ type let_kind = Strict | Alias | StrictOpt | Variable
       in e'
     StrictOpt: e does not have side-effects, but depend on the store;
       we can discard e if x does not appear in e'
-    Variable: the variable x is assigned later in e'
  *)
 
 type meth_kind = Self | Public | Cached
@@ -264,10 +263,12 @@ type scoped_location = Debuginfo.Scoped_location.t
 
 type lambda =
     Lvar of Ident.t
+  | Lmutvar of Ident.t
   | Lconst of structured_constant
   | Lapply of lambda_apply
   | Lfunction of lfunction
   | Llet of let_kind * value_kind * Ident.t * lambda * lambda
+  | Lmutlet of value_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list * scoped_location
   | Lswitch of lambda * lambda_switch * scoped_location

lambda/matching.ml

@@ -3549,6 +3549,7 @@ let simple_for_let ~scopes loc param pat body =
 
 let rec map_return f = function
   | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2)
+  | Lmutlet (k, id, l1, l2) -> Lmutlet (k, id, l1, map_return f l2)
   | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2)
   | Lifthenelse (lcond, lthen, lelse) ->
       Lifthenelse (lcond, map_return f lthen, map_return f lelse)
@@ -3576,8 +3577,8 @@ let rec map_return f = function
           Option.map (map_return f) def,
           loc )
   | (Lstaticraise _ | Lprim (Praise _, _, _)) as l -> l
-  | ( Lvar _ | Lconst _ | Lapply _ | Lfunction _ | Lsend _ | Lprim _ | Lwhile _
-    | Lfor _ | Lassign _ | Lifused _ ) as l ->
+  | ( Lvar _ | Lmutvar _ | Lconst _ | Lapply _ | Lfunction _ | Lsend _ | Lprim _
+    | Lwhile _ | Lfor _ | Lassign _ | Lifused _ ) as l ->
       f l
 
 (* The 'opt' reference indicates if the optimization is worthy.

lambda/printlambda.ml

@@ -495,6 +495,8 @@ let apply_specialised_attribute ppf = function
 let rec lam ppf = function
   | Lvar id ->
       Ident.print ppf id
+  | Lmutvar id ->
+      fprintf ppf "*%a" Ident.print id
   | Lconst cst ->
       struct_const ppf cst
   | Lapply ap ->
@@ -522,18 +524,26 @@ let rec lam ppf = function
             fprintf ppf ")" in
       fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params
         function_attribute attr return_kind return lam body
-  | Llet(str, k, id, arg, body) ->
-      let kind = function
-          Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v"
+  | Llet(_, k, id, arg, body)
+  | Lmutlet(k, id, arg, body) as l ->
+      let let_kind = begin function
+        | Llet(str,_,_,_,_) ->
+           begin match str with
+             Alias -> "a" | Strict -> "" | StrictOpt -> "o"
+           end
+        | Lmutlet _ -> "mut"
+        | _ -> assert false
+        end
       in
       let rec letbody = function
-        | Llet(str, k, id, arg, body) ->
-            fprintf ppf "@ @[<2>%a =%s%a@ %a@]"
-              Ident.print id (kind str) value_kind k lam arg;
-            letbody body
+        | Llet(_, k, id, arg, body)
+        | Lmutlet(k, id, arg, body) as l ->
+           fprintf ppf "@ @[<2>%a =%s%a@ %a@]"
+             Ident.print id (let_kind l) value_kind k lam arg;
+           letbody body
         | expr -> expr in
       fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%a@ %a@]"
-        Ident.print id (kind str) value_kind k lam arg;
+        Ident.print id (let_kind l) value_kind k lam arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
   | Lletrec(id_arg_list, body) ->

lambda/simplif.ml

@@ -27,7 +27,7 @@ exception Real_reference
 let rec eliminate_ref id = function
     Lvar v as lam ->
       if Ident.same v id then raise Real_reference else lam
-  | Lconst _ as lam -> lam
+  | Lmutvar _ | Lconst _ as lam -> lam
   | Lapply ap ->
       Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
                      ap_args = List.map (eliminate_ref id) ap.ap_args}
@@ -37,15 +37,17 @@ let rec eliminate_ref id = function
       else lam
   | Llet(str, kind, v, e1, e2) ->
       Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2)
+  | Lmutlet(kind, v, e1, e2) ->
+      Lmutlet(kind, v, eliminate_ref id e1, eliminate_ref id e2)
   | Lletrec(idel, e2) ->
       Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
               eliminate_ref id e2)
   | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
-      Lvar id
+      Lmutvar id
   | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
       Lassign(id, eliminate_ref id e)
   | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
-      Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))
+      Lassign(id, Lprim(Poffsetint delta, [Lmutvar id], loc))
   | Lprim(p, el, loc) ->
       Lprim(p, List.map (eliminate_ref id) el, loc)
   | Lswitch(e, sw, loc) ->
@@ -120,10 +122,11 @@ let simplify_exits lam =
   in
 
   let rec count = function
-  | (Lvar _| Lconst _) -> ()
+  | (Lvar _ | Lmutvar _ | Lconst _) -> ()
   | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args
   | Lfunction {body} -> count body
-  | Llet(_str, _kind, _v, l1, l2) ->
+  | Llet(_, _kind, _v, l1, l2)
+  | Lmutlet(_kind, _v, l1, l2) ->
       count l2; count l1
   | Lletrec(bindings, body) ->
       List.iter (fun (_v, l) -> count l) bindings;
@@ -203,13 +206,14 @@ let simplify_exits lam =
   let subst = Hashtbl.create 17 in
 
   let rec simplif = function
-  | (Lvar _|Lconst _) as l -> l
+  | (Lvar _ | Lmutvar _ | Lconst _) as l -> l
   | Lapply ap ->
       Lapply{ap with ap_func = simplif ap.ap_func;
                      ap_args = List.map simplif ap.ap_args}
   | Lfunction{kind; params; return; body = l; attr; loc} ->
      Lfunction{kind; params; return; body = simplif l; attr; loc}
   | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2)
+  | Lmutlet(kind, v, l1, l2) -> Lmutlet(kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
   | Lprim(p, ll, loc) -> begin
@@ -407,7 +411,8 @@ let simplify_lets lam =
   let rec count bv = function
   | Lconst _ -> ()
   | Lvar v ->
-      use_var bv v 1
+     use_var bv v 1
+  | Lmutvar _ -> ()
   | Lapply{ap_func = ll; ap_args = args} ->
       let no_opt () = count bv ll; List.iter (count bv) args in
       begin match ll with
@@ -430,6 +435,9 @@ let simplify_lets lam =
       count (bind_var bv v) l2;
       (* If v is unused, l1 will be removed, so don't count its variables *)
       if str = Strict || count_var v > 0 then count bv l1
+  | Lmutlet(_kind, _v, l1, l2) ->
+     count bv l1;
+     count bv l2
   | Lletrec(bindings, body) ->
       List.iter (fun (_v, l) -> count bv l) bindings;
       count bv body
@@ -491,10 +499,17 @@ let simplify_lets lam =
 (* This (small)  optimisation is always legal, it may uncover some
    tail call later on. *)
 
-  let mklet str kind v e1 e2  = match e2 with
-  | Lvar w when optimize && Ident.same v w -> e1
-  | _ -> Llet (str, kind,v,e1,e2) in
+  let mklet str kind v e1 e2 =
+    match e2 with
+    | Lvar w when optimize && Ident.same v w -> e1
+    | _ -> Llet (str, kind,v,e1,e2)
+  in
 
+  let mkmutlet kind v e1 e2 =
+    match e2 with
+    | Lmutvar w when optimize && Ident.same v w -> e1
+    | _ -> Lmutlet (kind,v,e1,e2)
+  in
 
   let rec simplif = function
     Lvar v as l ->
@@ -503,7 +518,7 @@ let simplify_lets lam =
       with Not_found ->
         l
       end
-  | Lconst _ as l -> l
+  | Lmutvar _ | Lconst _ as l -> l
   | Lapply ({ap_func = ll; ap_args = args} as ap) ->
       let no_opt () =
         Lapply {ap with ap_func = simplif ap.ap_func;
@@ -545,7 +560,7 @@ let simplify_lets lam =
           | Some [field_kind] -> field_kind
           | Some _ -> assert false
         in
-        mklet Variable kind v slinit (eliminate_ref v slbody)
+        mkmutlet kind v slinit (eliminate_ref v slbody)
       with Real_reference ->
         mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody
       end
@@ -561,6 +576,7 @@ let simplify_lets lam =
       | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2)
       end
   | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2)
+  | Lmutlet(kind, v, l1, l2) -> mkmutlet kind v (simplif l1) (simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
   | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
@@ -606,6 +622,7 @@ let simplify_lets lam =
 let rec emit_tail_infos is_tail lambda =
   match lambda with
   | Lvar _ -> ()
+  | Lmutvar _ -> ()
   | Lconst _ -> ()
   | Lapply ap ->
       begin
@@ -629,7 +646,8 @@ let rec emit_tail_infos is_tail lambda =
       list_emit_tail_infos false ap.ap_args
   | Lfunction {body = lam} ->
       emit_tail_infos true lam
-  | Llet (_str, _k, _, lam, body) ->
+  | Llet (_, _k, _, lam, body)
+  | Lmutlet (_k, _, lam, body) ->
       emit_tail_infos false lam;
       emit_tail_infos is_tail body
   | Lletrec (bindings, body) ->