Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Lambda.subst: also update debug event environments #1751

Merged
merged 3 commits into from Jul 19, 2018
Merged

Lambda.subst: also update debug event environments #1751

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
e6ce844
lambda_event contains actual env, not a summary
trefis May 1, 2018
bb3e89d
Lambda.subst: update debug events environments
trefis May 1, 2018
a7ce8de
Changes
trefis May 4, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
3 changes: 3 additions & 0 deletions Changes
View file
Open in desktop
Expand Up @@ -207,6 +207,9 @@ Working version
- GPR#1739: ensure ocamltest waits for child processes to terminate on Windows.
(David Allsopp, review by Sébastien Hinderer)

- MPR#7554, GPR#1751: Lambda.subst: also update debug event environments
(Thomas Refis, review by Gabriel Scherer)

- MPR#7238, GPR#1825: in Unix.in_channel_of_descr and Unix.out_channel_of_descr,
raise an error if the given file description is not suitable for
character-oriented I/O, for example if it is a block device or a
Expand Down
2 changes: 1 addition & 1 deletion bytecomp/bytegen.ml
View file
Open in desktop
Expand Up @@ -843,7 +843,7 @@ let rec comp_expr env exp sz cont =
ev_loc = lev.lev_loc;
ev_kind = kind;
ev_info = info;
ev_typenv = lev.lev_env;
ev_typenv = Env.summary lev.lev_env;
ev_typsubst = Subst.identity;
ev_compenv = env;
ev_stacksize = sz;
Expand Down
136 changes: 77 additions & 59 deletions bytecomp/lambda.ml
View file
Open in desktop
Expand Up @@ -314,7 +314,7 @@ and lambda_event =
{ lev_loc: Location.t;
lev_kind: lambda_event_kind;
lev_repr: int ref option;
lev_env: Env.summary }
lev_env: Env.t }
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is this a wise choice? I thought that Env.summary was designed precisely to be the "compact" part of the environment for use in debug information.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not sure where you got that from, but you probably have better sources than I do. I'm also not sure what you're worried about: we still "summarize" these environment when transforming lambda to the next AST, they are never marshalled or anything.
Considering we still have modifications to do on the environment at this point, I think it make more sense to actually modify Env.ts than the summaries.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

One wouldn't think of looking there but I got it from env.mli :-)

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Indeed, I hadn't looked there.
Then again, depends how you interpret it. Does "compact" refer to the marshalled representation that end up in .cmo files (or similar), or to something else? My bet is on the former, in which case I believe my change is fine.


and lambda_event_kind =
Lev_before
Expand Down Expand Up @@ -641,66 +641,84 @@ let rec make_sequence fn = function
Assumes that the image of the substitution is out of reach
of the bound variables of the lambda-term (no capture). *)

let rec subst s lam =
let remove_list l s =
List.fold_left (fun s id -> Ident.Map.remove id s) s l
let subst update_env s lam =
let rec subst s lam =
let remove_list l s =
List.fold_left (fun s id -> Ident.Map.remove id s) s l
in
let module M = Ident.Map in
match lam with
| Lvar id as l ->
begin try Ident.Map.find id s with Not_found -> l end
| Lconst _ as l -> l
| Lapply ap ->
Lapply{ap with ap_func = subst s ap.ap_func;
ap_args = subst_list s ap.ap_args}
| Lfunction{kind; params; body; attr; loc} ->
let s = List.fold_right Ident.Map.remove params s in
Lfunction{kind; params; body = subst s body; attr; loc}
| Llet(str, k, id, arg, body) ->
Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body)
| Lletrec(decl, body) ->
let s =
List.fold_left (fun s (id, _) -> Ident.Map.remove id s)
s decl
in
Lletrec(List.map (subst_decl s) decl, subst s body)
| Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc)
| Lswitch(arg, sw, loc) ->
Lswitch(subst s arg,
{sw with sw_consts = List.map (subst_case s) sw.sw_consts;
sw_blocks = List.map (subst_case s) sw.sw_blocks;
sw_failaction = subst_opt s sw.sw_failaction; },
loc)
| Lstringswitch (arg,cases,default,loc) ->
Lstringswitch
(subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc)
| Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args)
| Lstaticcatch(body, (id, params), handler) ->
Lstaticcatch(subst s body, (id, params),
subst (remove_list params s) handler)
| Ltrywith(body, exn, handler) ->
Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler)
| Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3)
| Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2)
| Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2)
| Lfor(v, lo, hi, dir, body) ->
Lfor(v, subst s lo, subst s hi, dir,
subst (Ident.Map.remove v s) body)
| Lassign(id, e) ->
assert(not (Ident.Map.mem id s));
Lassign(id, subst s e)
| Lsend (k, met, obj, args, loc) ->
Lsend (k, subst s met, subst s obj, subst_list s args, loc)
| Levent (lam, evt) ->
let lev_env =
Ident.Map.fold (fun id _ env ->
match Env.find_value (Path.Pident id) evt.lev_env with
| exception Not_found -> env
| vd -> update_env id vd env
) s evt.lev_env
in
Levent (subst s lam, { evt with lev_env })
| Lifused (v, e) -> Lifused (v, subst s e)
and subst_list s l = List.map (subst s) l
and subst_decl s (id, exp) = (id, subst s exp)
and subst_case s (key, case) = (key, subst s case)
and subst_strcase s (key, case) = (key, subst s case)
and subst_opt s = function
| None -> None
| Some e -> Some (subst s e)
in
let module M = Ident.Map in
match lam with
| Lvar id as l ->
begin try Ident.Map.find id s with Not_found -> l end
| Lconst _ as l -> l
| Lapply ap ->
Lapply{ap with ap_func = subst s ap.ap_func;
ap_args = subst_list s ap.ap_args}
| Lfunction{kind; params; body; attr; loc} ->
let s = List.fold_right Ident.Map.remove params s in
Lfunction{kind; params; body = subst s body; attr; loc}
| Llet(str, k, id, arg, body) ->
Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body)
| Lletrec(decl, body) ->
let s =
List.fold_left (fun s (id, _) -> Ident.Map.remove id s)
s decl
in
Lletrec(List.map (subst_decl s) decl, subst s body)
| Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc)
| Lswitch(arg, sw, loc) ->
Lswitch(subst s arg,
{sw with sw_consts = List.map (subst_case s) sw.sw_consts;
sw_blocks = List.map (subst_case s) sw.sw_blocks;
sw_failaction = subst_opt s sw.sw_failaction; },
loc)
| Lstringswitch (arg,cases,default,loc) ->
Lstringswitch
(subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc)
| Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args)
| Lstaticcatch(body, (id, params), handler) ->
Lstaticcatch(subst s body, (id, params),
subst (remove_list params s) handler)
| Ltrywith(body, exn, handler) ->
Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler)
| Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3)
| Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2)
| Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2)
| Lfor(v, lo, hi, dir, body) ->
Lfor(v, subst s lo, subst s hi, dir,
subst (Ident.Map.remove v s) body)
| Lassign(id, e) ->
assert(not (Ident.Map.mem id s));
Lassign(id, subst s e)
| Lsend (k, met, obj, args, loc) ->
Lsend (k, subst s met, subst s obj, subst_list s args, loc)
| Levent (lam, evt) -> Levent (subst s lam, evt)
| Lifused (v, e) -> Lifused (v, subst s e)
and subst_list s l = List.map (subst s) l
and subst_decl s (id, exp) = (id, subst s exp)
and subst_case s (key, case) = (key, subst s case)
and subst_strcase s (key, case) = (key, subst s case)
and subst_opt s = function
| None -> None
| Some e -> Some (subst s e)
subst s lam

let rename idmap lam =
let update_env oldid vd env =
let newid = Ident.Map.find oldid idmap in
Env.add_value newid vd env
in
let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in
subst update_env s lam

let rec map f lam =
let lam =
Expand Down
18 changes: 14 additions & 4 deletions bytecomp/lambda.mli
View file
Open in desktop
Expand Up @@ -296,7 +296,7 @@ and lambda_event =
{ lev_loc: Location.t;
lev_kind: lambda_event_kind;
lev_repr: int ref option;
lev_env: Env.summary }
lev_env: Env.t }

and lambda_event_kind =
Lev_before
Expand Down Expand Up @@ -349,10 +349,20 @@ val transl_class_path: ?loc:Location.t -> Env.t -> Path.t -> lambda

val make_sequence: ('a -> lambda) -> 'a list -> lambda

val subst: lambda Ident.Map.t -> lambda -> lambda
(** Apply a substitution to a lambda-term.
val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) ->
lambda Ident.Map.t -> lambda -> lambda
(** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term
[lt].

Assumes that the image of the substitution is out of reach
of the bound variables of the lambda-term (no capture). *)
of the bound variables of the lambda-term (no capture).

[env_update_fun] is used to refresh the environment contained in debug
events. *)

val rename : Ident.t Ident.Map.t -> lambda -> lambda
(** A version of [subst] specialized for the case where we're just renaming
idents. *)

val map : (lambda -> lambda) -> lambda -> lambda
val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
Expand Down
17 changes: 7 additions & 10 deletions bytecomp/simplif.ml
View file
Open in desktop
Expand Up @@ -264,13 +264,10 @@ let simplify_exits lam =
begin try
let xs,handler = Hashtbl.find subst i in
let ys = List.map Ident.rename xs in
let env =
List.fold_right2
(fun x y t -> Ident.Map.add x (Lvar y) t)
xs ys Ident.Map.empty in
let env = List.fold_right2 Ident.Map.add xs ys Ident.Map.empty in
List.fold_right2
(fun y l r -> Llet (Alias, Pgenval, y, l, r))
ys ls (Lambda.subst env handler)
ys ls (Lambda.rename env handler)
with
| Not_found -> Lstaticraise (i,ls)
end
Expand Down Expand Up @@ -680,12 +677,12 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
in
let inner_params = List.map map_param params in
let new_ids = List.map Ident.rename inner_params in
let subst = List.fold_left2
(fun s id new_id ->
Ident.Map.add id (Lvar new_id) s)
Ident.Map.empty inner_params new_ids
let subst =
List.fold_left2 (fun s id new_id ->
Ident.Map.add id new_id s
) Ident.Map.empty inner_params new_ids
in
let body = Lambda.subst subst body in
let body = Lambda.rename subst body in
let inner_fun =
Lfunction { kind = Curried; params = new_ids; body; attr; loc; }
in
Expand Down
5 changes: 3 additions & 2 deletions bytecomp/translclass.ml
View file
Open in desktop
Expand Up @@ -690,12 +690,13 @@ let transl_class ids cl_id pub_meths cl vflag =
Ident.Map.empty !new_ids'
in
let new_ids_meths = ref [] in
let no_env_update _ _ env = env in
let msubst arr = function
Lfunction {kind = Curried; params = self :: args; body} ->
let env = Ident.create "env" in
let body' =
if new_ids = [] then body else
Lambda.subst (subst env body 0 new_ids_meths) body in
Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
begin try
(* Doesn't seem to improve size for bytecode *)
(* if not !Clflags.native_code then raise Not_found; *)
Expand All @@ -722,7 +723,7 @@ let transl_class ids cl_id pub_meths cl vflag =
and subst_env envs l lam =
if top then lam else
(* must be called only once! *)
let lam = Lambda.subst (subst env1 lam 1 new_ids_init) lam in
let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in
Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
Llet(Alias, Pgenval, env1',
(if !new_ids_init = [] then Lvar env1 else lfield env1 0),
Expand Down
4 changes: 2 additions & 2 deletions bytecomp/translcore.ml
View file
Open in desktop
Expand Up @@ -156,7 +156,7 @@ let event_function exp lam =
Levent(body, {lev_loc = exp.exp_loc;
lev_kind = Lev_function;
lev_repr = repr;
lev_env = Env.summary exp.exp_env}))
lev_env = exp.exp_env}))
else
lam None

Expand Down Expand Up @@ -456,7 +456,7 @@ and transl_exp0 e =
lev_loc = loc.loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.summary Env.empty;
lev_env = Env.empty;
})
in
Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
Expand Down