diff options
| -rw-r--r-- | bytecomp/bytegen.ml | 2 | ||||
| -rw-r--r-- | lambda/lambda.ml | 17 | ||||
| -rw-r--r-- | lambda/lambda.mli | 1 | ||||
| -rw-r--r-- | lambda/matching.ml | 4 | ||||
| -rw-r--r-- | lambda/printlambda.ml | 4 | ||||
| -rw-r--r-- | lambda/simplif.ml | 13 | ||||
| -rw-r--r-- | lambda/translclass.ml | 2 | ||||
| -rw-r--r-- | middle_end/closure/closure.ml | 2 | ||||
| -rw-r--r-- | middle_end/flambda/closure_conversion.ml | 2 |
9 files changed, 31 insertions, 16 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 4931456588..dd7895fd65 100644 --- a/bytecomp/bytegen.ml +++ b/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 diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 7106785147..fa6abb851e 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -284,6 +284,7 @@ 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 @@ -382,7 +383,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 @@ -479,12 +481,13 @@ 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) -> f arg; tail body | Lletrec(decl, body) -> tail body; @@ -533,7 +536,8 @@ 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 @@ -715,6 +719,12 @@ 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 -> + 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; @@ -818,6 +828,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 } -> diff --git a/lambda/lambda.mli b/lambda/lambda.mli index fa29315dcd..2387479e58 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -264,6 +264,7 @@ 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 diff --git a/lambda/matching.ml b/lambda/matching.ml index 65ffb2316b..8f9c7b7bf1 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -3576,8 +3576,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. diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index e73af87f2a..a967141bd8 100644 --- a/lambda/printlambda.ml +++ b/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 -> @@ -523,7 +525,7 @@ let rec lam ppf = function 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 + let kind = function Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in let rec letbody = function diff --git a/lambda/simplif.ml b/lambda/simplif.ml index dfb556f35a..559c7c8460 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -25,7 +25,7 @@ open Debuginfo.Scoped_location exception Real_reference let rec eliminate_ref id = function - Lvar v as lam -> + Lvar v | Lmutvar v as lam -> if Ident.same v id then raise Real_reference else lam | Lconst _ as lam -> lam | Lapply ap -> @@ -41,7 +41,7 @@ let rec eliminate_ref id = function 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 -> @@ -120,7 +120,7 @@ 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) -> @@ -203,7 +203,7 @@ 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} @@ -406,7 +406,7 @@ let simplify_lets lam = let rec count bv = function | Lconst _ -> () - | Lvar v -> + | Lvar v | Lmutvar v -> use_var bv v 1 | Lapply{ap_func = ll; ap_args = args} -> let no_opt () = count bv ll; List.iter (count bv) args in @@ -497,7 +497,7 @@ let simplify_lets lam = let rec simplif = function - Lvar v as l -> + Lvar v | Lmutvar v as l -> begin try Hashtbl.find subst v with Not_found -> @@ -606,6 +606,7 @@ let simplify_lets lam = let rec emit_tail_infos is_tail lambda = match lambda with | Lvar _ -> () + | Lmutvar _ -> () | Lconst _ -> () | Lapply ap -> begin diff --git a/lambda/translclass.ml b/lambda/translclass.ml index a465579811..e7feec9243 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -674,7 +674,7 @@ let free_methods l = | Lfor(v, _e1, _e2, _dir, _e3) -> fv := Ident.Set.remove v !fv | Lassign _ - | Lvar _ | Lconst _ | Lapply _ + | Lvar _ | Lmutvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Levent _ | Lifused _ -> () diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index a51768216c..65f60ef370 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -861,7 +861,7 @@ let close_var env id = let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = let module B = (val backend : Backend_intf.S) in match lam with - | Lvar id -> + | Lvar id | Lmutvar id -> close_approx_var env id | Lconst cst -> let str ?(shared = true) cst = diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 8c731a9faa..14261b4874 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -170,7 +170,7 @@ let lambda_const_int i : Lambda.structured_constant = let rec close t env (lam : Lambda.lambda) : Flambda.t = match lam with - | Lvar id -> + | Lvar id | Lmutvar id -> begin match Env.find_var_exn env id with | var -> Var var | exception Not_found -> |