Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add debugging 'pseudo' events at the end of structures 

This debugging event provides information regarding the structure items.
It is ignored by the OCaml debugger but is used by Js_of_ocaml to
preserve variable names for debugging purpose.
master
Jerome Vouillon 2016-02-02 11:44:17 +01:00
parent 50dd38d4b6
commit 188e59fae5
5 changed files with 43 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bytecomp/bytegen.ml
View File

@ -830,6 +830,10 @@ let rec comp_expr env exp sz cont =
let c = comp_expr env lam sz cont in
let ev = event Event_pseudo Event_function in
add_event ev c
| Lev_pseudo ->
let c = comp_expr env lam sz cont in
let ev = event Event_pseudo Event_other in
add_event ev c
| Lev_after _ when is_tailcall cont -> (* don't destroy tail call opt *)
comp_expr env lam sz cont
| Lev_after ty ->

1
bytecomp/lambda.ml
View File

@ -242,6 +242,7 @@ and lambda_event_kind =
Lev_before
| Lev_after of Types.type_expr
| Lev_function
| Lev_pseudo
type program =
{ code : lambda;

1
bytecomp/lambda.mli
View File

@ -258,6 +258,7 @@ and lambda_event_kind =
Lev_before
| Lev_after of Types.type_expr
| Lev_function
| Lev_pseudo
type program =
{ code : lambda;

4
bytecomp/printlambda.ml
View File

@ -512,7 +512,9 @@ let rec lam ppf = function
match ev.lev_kind with
| Lev_before -> "before"
| Lev_after _ -> "after"
| Lev_function -> "funct-body" in
| Lev_function -> "funct-body"
| Lev_pseudo -> "pseudo"
in
fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
ev.lev_loc.Location.loc_start.Lexing.pos_fname
ev.lev_loc.Location.loc_start.Lexing.pos_lnum

49
bytecomp/translmod.ml
View File

@ -400,11 +400,12 @@ let rec transl_module cc rootpath mexp =
apply_coercion Strict cc (Translcore.transl_exp arg)
and transl_struct fields cc rootpath str =
transl_structure fields cc rootpath str.str_items
transl_structure fields cc rootpath str.str_final_env str.str_items
and transl_structure fields cc rootpath = function
and transl_structure fields cc rootpath final_env = function
[] ->
begin match cc with
let body, size =
match cc with
Tcoerce_none ->
Lprim(Pmakeblock(0, Immutable),
List.map (fun id -> Lvar id) (List.rev fields)),
@ -435,36 +436,52 @@ and transl_structure fields cc rootpath = function
List.length pos_cc_list
| _ ->
fatal_error "Translmod.transl_structure"
end
in
(* This debugging event provides information regarding the structure
items. It is ignored by the OCaml debugger but is used by
Js_of_ocaml to preserve variable names. *)
(if !Clflags.debug then
Levent(body,
{lev_loc = Location.none;
lev_kind = Lev_pseudo;
lev_repr = None;
lev_env = Env.summary final_env})
else
body),
size
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _) ->
let body, size = transl_structure fields cc rootpath rem in
let body, size = transl_structure fields cc rootpath final_env rem in
Lsequence(transl_exp expr, body), size
| Tstr_value(rec_flag, pat_expr_list) ->
let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
let body, size = transl_structure ext_fields cc rootpath rem in
let body, size =
transl_structure ext_fields cc rootpath final_env rem in
transl_let rec_flag pat_expr_list body, size
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_structure fields cc rootpath rem
transl_structure fields cc rootpath final_env rem
| Tstr_type(_, decls) ->
transl_structure fields cc rootpath rem
transl_structure fields cc rootpath final_env rem
| Tstr_typext(tyext) ->
let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
let body, size =
transl_structure (List.rev_append ids fields) cc rootpath rem
transl_structure (List.rev_append ids fields)
cc rootpath final_env rem
in
transl_type_extension item.str_env rootpath tyext body, size
| Tstr_exception ext ->
let id = ext.ext_id in
let path = field_path rootpath id in
let body, size = transl_structure (id :: fields) cc rootpath rem in
let body, size =
transl_structure (id :: fields) cc rootpath final_env rem in
Llet(Strict, id, transl_extension_constructor item.str_env path ext,
body), size
| Tstr_module mb ->
let id = mb.mb_id in
let body, size = transl_structure (id :: fields) cc rootpath rem in
let body, size =
transl_structure (id :: fields) cc rootpath final_env rem in
let module_body =
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
in
@ -478,7 +495,8 @@ and transl_structure fields cc rootpath = function
let ext_fields =
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
in
let body, size = transl_structure ext_fields cc rootpath rem in
let body, size =
transl_structure ext_fields cc rootpath final_env rem in
let lam =
compile_recmodule
(fun id modl ->
@ -490,7 +508,8 @@ and transl_structure fields cc rootpath = function
| Tstr_class cl_list ->
let (ids, class_bindings) = transl_class_bindings cl_list in
let body, size =
transl_structure (List.rev_append ids fields) cc rootpath rem
transl_structure (List.rev_append ids fields)
cc rootpath final_env rem
in
Lletrec(class_bindings, body), size
| Tstr_include incl ->
@ -499,7 +518,7 @@ and transl_structure fields cc rootpath = function
let mid = Ident.create "include" in
let rec rebind_idents pos newfields = function
[] ->
transl_structure newfields cc rootpath rem
transl_structure newfields cc rootpath final_env rem
| id :: ids ->
let body, size = rebind_idents (pos + 1) (id :: newfields) ids in
Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), body), size
@ -512,7 +531,7 @@ and transl_structure fields cc rootpath = function
| Tstr_open _
| Tstr_class_type _
| Tstr_attribute _ ->
transl_structure fields cc rootpath rem
transl_structure fields cc rootpath final_env rem
and pure_module m =
match m.mod_desc with