summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.depend51
-rw-r--r--bytecomp/bytegen.ml41
-rw-r--r--bytecomp/bytelink.ml49
-rw-r--r--bytecomp/emitcode.ml18
-rw-r--r--bytecomp/emitcode.mli7
-rw-r--r--bytecomp/instruct.ml18
-rw-r--r--bytecomp/instruct.mli32
-rw-r--r--bytecomp/lambda.ml12
-rw-r--r--bytecomp/lambda.mli10
-rw-r--r--bytecomp/printinstr.ml1
-rw-r--r--bytecomp/printlambda.ml11
-rw-r--r--bytecomp/simplif.ml4
-rw-r--r--bytecomp/symtable.ml4
-rw-r--r--bytecomp/symtable.mli1
-rw-r--r--bytecomp/translcore.ml56
-rw-r--r--byterun/Makefile3
-rw-r--r--byterun/fix_code.c53
-rw-r--r--byterun/fix_code.h7
-rw-r--r--byterun/instruct.h4
-rw-r--r--byterun/interp.c56
-rw-r--r--byterun/stacks.c3
-rw-r--r--byterun/stacks.h1
-rw-r--r--byterun/startup.c17
-rw-r--r--byterun/sys.c2
-rw-r--r--driver/main.ml1
-rw-r--r--typing/env.ml116
-rw-r--r--typing/env.mli16
-rw-r--r--utils/clflags.ml1
28 files changed, 476 insertions, 119 deletions
diff --git a/.depend b/.depend
index 4ad367ce6..410adc3fc 100644
--- a/.depend
+++ b/.depend
@@ -155,13 +155,13 @@ typing/typecore.cmx: parsing/asttypes.cmi typing/ctype.cmx typing/env.cmx \
typing/typedecl.cmo: utils/config.cmi typing/ctype.cmi typing/env.cmi \
typing/ident.cmi typing/includecore.cmi parsing/location.cmi \
parsing/parsetree.cmi typing/primitive.cmi typing/printtyp.cmi \
- typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \
- typing/typedecl.cmi
+ typing/subst.cmi typing/typedtree.cmi typing/types.cmi \
+ typing/typetexp.cmi typing/typedecl.cmi
typing/typedecl.cmx: utils/config.cmx typing/ctype.cmx typing/env.cmx \
typing/ident.cmx typing/includecore.cmx parsing/location.cmx \
parsing/parsetree.cmi typing/primitive.cmx typing/printtyp.cmx \
- typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \
- typing/typedecl.cmi
+ typing/subst.cmx typing/typedtree.cmx typing/types.cmx \
+ typing/typetexp.cmx typing/typedecl.cmi
typing/typedtree.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
parsing/location.cmi utils/misc.cmi typing/path.cmi typing/primitive.cmi \
typing/types.cmi typing/typedtree.cmi
@@ -194,9 +194,10 @@ bytecomp/bytegen.cmi: bytecomp/instruct.cmi bytecomp/lambda.cmi
bytecomp/bytelink.cmi: bytecomp/emitcode.cmi bytecomp/symtable.cmi
bytecomp/emitcode.cmi: typing/ident.cmi bytecomp/instruct.cmi \
bytecomp/lambda.cmi
-bytecomp/instruct.cmi: typing/ident.cmi bytecomp/lambda.cmi
-bytecomp/lambda.cmi: parsing/asttypes.cmi typing/ident.cmi typing/path.cmi \
- typing/primitive.cmi
+bytecomp/instruct.cmi: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
+ typing/types.cmi
+bytecomp/lambda.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
+ typing/path.cmi typing/primitive.cmi typing/types.cmi
bytecomp/matching.cmi: typing/ident.cmi bytecomp/lambda.cmi \
parsing/location.cmi typing/typedtree.cmi
bytecomp/printinstr.cmi: bytecomp/instruct.cmi
@@ -211,21 +212,23 @@ bytecomp/translcore.cmi: parsing/asttypes.cmi typing/ident.cmi \
bytecomp/translmod.cmi: bytecomp/lambda.cmi typing/typedtree.cmi
bytecomp/translobj.cmi: typing/ident.cmi bytecomp/lambda.cmi
bytecomp/bytegen.cmo: parsing/asttypes.cmi typing/ident.cmi \
- bytecomp/instruct.cmi bytecomp/lambda.cmi utils/misc.cmi \
- typing/primitive.cmi typing/types.cmi bytecomp/bytegen.cmi
+ bytecomp/instruct.cmi bytecomp/lambda.cmi parsing/location.cmi \
+ utils/misc.cmi typing/primitive.cmi typing/types.cmi bytecomp/bytegen.cmi
bytecomp/bytegen.cmx: parsing/asttypes.cmi typing/ident.cmx \
- bytecomp/instruct.cmx bytecomp/lambda.cmx utils/misc.cmx \
- typing/primitive.cmx typing/types.cmx bytecomp/bytegen.cmi
+ bytecomp/instruct.cmx bytecomp/lambda.cmx parsing/location.cmx \
+ utils/misc.cmx typing/primitive.cmx typing/types.cmx bytecomp/bytegen.cmi
bytecomp/bytelibrarian.cmo: utils/clflags.cmo utils/config.cmi \
bytecomp/emitcode.cmi utils/misc.cmi bytecomp/bytelibrarian.cmi
bytecomp/bytelibrarian.cmx: utils/clflags.cmx utils/config.cmx \
bytecomp/emitcode.cmx utils/misc.cmx bytecomp/bytelibrarian.cmi
bytecomp/bytelink.cmo: utils/ccomp.cmi utils/clflags.cmo utils/config.cmi \
- bytecomp/emitcode.cmi typing/ident.cmi utils/misc.cmi \
- bytecomp/opcodes.cmo bytecomp/symtable.cmi bytecomp/bytelink.cmi
+ bytecomp/emitcode.cmi typing/ident.cmi bytecomp/instruct.cmi \
+ utils/misc.cmi bytecomp/opcodes.cmo bytecomp/symtable.cmi \
+ bytecomp/bytelink.cmi
bytecomp/bytelink.cmx: utils/ccomp.cmx utils/clflags.cmx utils/config.cmx \
- bytecomp/emitcode.cmx typing/ident.cmx utils/misc.cmx \
- bytecomp/opcodes.cmx bytecomp/symtable.cmx bytecomp/bytelink.cmi
+ bytecomp/emitcode.cmx typing/ident.cmx bytecomp/instruct.cmx \
+ utils/misc.cmx bytecomp/opcodes.cmx bytecomp/symtable.cmx \
+ bytecomp/bytelink.cmi
bytecomp/emitcode.cmo: parsing/asttypes.cmi utils/config.cmi typing/env.cmi \
typing/ident.cmi bytecomp/instruct.cmi bytecomp/lambda.cmi \
bytecomp/meta.cmi utils/misc.cmi bytecomp/opcodes.cmo \
@@ -234,14 +237,16 @@ bytecomp/emitcode.cmx: parsing/asttypes.cmi utils/config.cmx typing/env.cmx \
typing/ident.cmx bytecomp/instruct.cmx bytecomp/lambda.cmx \
bytecomp/meta.cmx utils/misc.cmx bytecomp/opcodes.cmx \
bytecomp/translmod.cmx bytecomp/emitcode.cmi
-bytecomp/instruct.cmo: typing/ident.cmi bytecomp/lambda.cmi \
- bytecomp/instruct.cmi
-bytecomp/instruct.cmx: typing/ident.cmx bytecomp/lambda.cmx \
- bytecomp/instruct.cmi
-bytecomp/lambda.cmo: parsing/asttypes.cmi typing/ident.cmi utils/misc.cmi \
- typing/path.cmi typing/primitive.cmi bytecomp/lambda.cmi
-bytecomp/lambda.cmx: parsing/asttypes.cmi typing/ident.cmx utils/misc.cmx \
- typing/path.cmx typing/primitive.cmx bytecomp/lambda.cmi
+bytecomp/instruct.cmo: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
+ typing/types.cmi bytecomp/instruct.cmi
+bytecomp/instruct.cmx: typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \
+ typing/types.cmx bytecomp/instruct.cmi
+bytecomp/lambda.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
+ utils/misc.cmi typing/path.cmi typing/primitive.cmi typing/types.cmi \
+ bytecomp/lambda.cmi
+bytecomp/lambda.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \
+ utils/misc.cmx typing/path.cmx typing/primitive.cmx typing/types.cmx \
+ bytecomp/lambda.cmi
bytecomp/matching.cmo: parsing/asttypes.cmi typing/ctype.cmi typing/ident.cmi \
bytecomp/lambda.cmi parsing/location.cmi utils/misc.cmi typing/predef.cmi \
typing/primitive.cmi typing/typedtree.cmi typing/types.cmi \
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 8e54fdc22..5624d4715 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -27,17 +27,7 @@ let label_counter = ref 0
let new_label () =
incr label_counter; !label_counter
-(**** Structure of the compilation environment. ****)
-
-type compilation_env =
- { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
- ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *)
-
-(* The ce_stack component gives locations of variables residing
- in the stack. The locations are offsets w.r.t. the origin of the
- stack frame.
- The ce_heap component gives the positions of variables residing in the
- heap-allocated environment. *)
+(**** Operations on compilation environments. ****)
let empty_env =
{ ce_stack = Ident.empty; ce_heap = Ident.empty }
@@ -402,7 +392,34 @@ let rec comp_expr env exp sz cont =
with Not_found ->
fatal_error "Bytegen.comp_expr: assign"
end
-
+ | Levent(lam, lev) ->
+ let ev =
+ { ev_pos = 0; (* patched in emitcode *)
+ ev_file = !Location.input_name;
+ ev_char = lev.lev_loc;
+ ev_kind = begin match lev.lev_kind with
+ Lev_before -> Event_before
+ | Lev_after ty -> Event_after ty
+ end;
+ ev_typenv = lev.lev_env;
+ ev_compenv = env;
+ ev_stacksize = sz } in
+ begin match lev.lev_kind with
+ Lev_before ->
+ let c = comp_expr env lam sz cont in
+ begin match c with
+ (* Keep following event, supposedly more informative *)
+ Kevent _ :: _ -> c
+ | _ -> Kevent ev :: c
+ end
+ | Lev_after ty ->
+ let cont1 =
+ (* Discard following events, supposedly less informative *)
+ match cont with
+ Kevent _ :: c -> c
+ | _ -> cont in
+ comp_expr env lam sz (Kevent ev :: cont1)
+ end
(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
The values of eN ... e2 are pushed on the stack, e2 at top of stack,
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 4176d26cd..476278e26 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -16,6 +16,7 @@
open Sys
open Misc
open Config
+open Instruct
open Emitcode
type error =
@@ -111,6 +112,8 @@ let scan_file obj_name tolink =
(* Second pass: link in the required units *)
+let debug_info = ref ([] : debug_event list list)
+
(* Consistency check between interfaces *)
let crc_interfaces =
@@ -130,24 +133,35 @@ let check_consistency file_name cu =
cu.cu_imports;
Hashtbl.add crc_interfaces cu.cu_name (file_name, cu.cu_interface)
+(* Relocate and record compilation events *)
+
+let debug_info = ref ([] : debug_event list list)
+
+let record_events orig evl =
+ if evl <> [] then begin
+ List.iter (fun ev -> ev.ev_pos <- orig + ev.ev_pos) evl;
+ debug_info := evl :: !debug_info
+ end
+
(* Link in a compilation unit *)
-let link_compunit output_fun inchan file_name compunit =
+let link_compunit output_fun currpos_fun inchan file_name compunit =
check_consistency file_name compunit;
seek_in inchan compunit.cu_pos;
let code_block = String.create compunit.cu_codesize in
really_input inchan code_block 0 compunit.cu_codesize;
Symtable.patch_object code_block compunit.cu_reloc;
+ if !Clflags.debug then record_events (currpos_fun()) compunit.cu_events;
output_fun code_block;
if !Clflags.link_everything then
List.iter Symtable.require_primitive compunit.cu_primitives
(* Link in a .cmo file *)
-let link_object output_fun file_name compunit =
+let link_object output_fun currpos_fun file_name compunit =
let inchan = open_in_bin file_name in
try
- link_compunit output_fun inchan file_name compunit;
+ link_compunit output_fun currpos_fun inchan file_name compunit;
close_in inchan
with
Symtable.Error msg ->
@@ -157,10 +171,12 @@ let link_object output_fun file_name compunit =
(* Link in a .cma file *)
-let link_archive output_fun file_name units_required =
+let link_archive output_fun currpos_fun file_name units_required =
let inchan = open_in_bin file_name in
try
- List.iter (link_compunit output_fun inchan file_name) units_required;
+ List.iter
+ (link_compunit output_fun currpos_fun inchan file_name)
+ units_required;
close_in inchan
with
Symtable.Error msg ->
@@ -170,9 +186,11 @@ let link_archive output_fun file_name units_required =
(* Link in a .cmo or .cma file *)
-let link_file output_fun = function
- Link_object(file_name, unit) -> link_object output_fun file_name unit
- | Link_archive(file_name, units) -> link_archive output_fun file_name units
+let link_file output_fun currpos_fun = function
+ Link_object(file_name, unit) ->
+ link_object output_fun currpos_fun file_name unit
+ | Link_archive(file_name, units) ->
+ link_archive output_fun currpos_fun file_name units
(* Create a bytecode executable file *)
@@ -198,7 +216,9 @@ let link_bytecode objfiles exec_name copy_header =
let pos1 = pos_out outchan in
Symtable.init();
Hashtbl.clear crc_interfaces;
- List.iter (link_file (output_string outchan)) tolink;
+ let output_fun = output_string outchan
+ and currpos_fun () = pos_out outchan - pos1 in
+ List.iter (link_file output_fun currpos_fun) tolink;
(* The final STOP instruction *)
output_byte outchan Opcodes.opSTOP;
output_byte outchan 0; output_byte outchan 0; output_byte outchan 0;
@@ -208,12 +228,15 @@ let link_bytecode objfiles exec_name copy_header =
(* The map of global identifiers *)
let pos3 = pos_out outchan in
Symtable.output_global_map outchan;
- (* The trailer *)
+ (* Debug info *)
let pos4 = pos_out outchan in
+ if !Clflags.debug then output_value outchan !debug_info;
+ (* The trailer *)
+ let pos5 = pos_out outchan in
output_binary_int outchan (pos2 - pos1);
output_binary_int outchan (pos3 - pos2);
output_binary_int outchan (pos4 - pos3);
- output_binary_int outchan 0;
+ output_binary_int outchan (pos5 - pos4);
output_string outchan exec_magic_number;
close_out outchan
with x ->
@@ -267,7 +290,9 @@ let link_bytecode_as_c objfiles outfile =
output_string outchan "static int caml_code[] = {\n";
Symtable.init();
Hashtbl.clear crc_interfaces;
- List.iter (link_file (output_code_string outchan)) tolink;
+ let output_fun = output_code_string outchan
+ and currpos_fun () = fatal_error "Bytelink.link_bytecode_as_c" in
+ List.iter (link_file output_fun currpos_fun) tolink;
(* The final STOP instruction *)
Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP;
(* The table of global data *)
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index e03a20dbc..ffd7698a4 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -39,7 +39,8 @@ type compilation_unit =
cu_interface: Digest.t; (* CRC of interface implemented *)
cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
cu_primitives: string list; (* Primitives declared inside *)
- mutable cu_force_link: bool } (* Must be linked even if unref'ed *)
+ mutable cu_force_link: bool; (* Must be linked even if unref'ed *)
+ cu_events: debug_event list } (* Debugging events *)
(* Format of a .cmo file:
magic number (Config.cmo_magic_number)
@@ -135,12 +136,21 @@ and slot_for_c_prim name =
enter (Reloc_primitive name);
out_int 0
+(* Debugging events *)
+
+let events = ref ([] : debug_event list)
+
+let record_event ev =
+ ev.ev_pos <- !out_position;
+ events := ev :: !events
+
(* Initialization *)
let init () =
out_position := 0;
label_table := Array.create 16 (Label_undefined []);
- reloc_info := []
+ reloc_info := [];
+ events := []
(* Emission of one instruction *)
@@ -235,6 +245,7 @@ let emit_instr = function
| Koffsetint n -> out opOFFSETINT; out_int n
| Koffsetref n -> out opOFFSETREF; out_int n
| Kgetmethod -> out opGETMETHOD
+ | Kevent ev -> record_event ev
| Kstop -> out opSTOP
(* Emission of a list of instructions. Include some peephole optimization. *)
@@ -291,7 +302,8 @@ let to_file outchan unit_name crc_interface code =
cu_interface = crc_interface;
cu_imports = Env.imported_units();
cu_primitives = !Translmod.primitive_declarations;
- cu_force_link = false } in
+ cu_force_link = false;
+ cu_events = !events } in
init(); (* Free out_buffer and reloc_info *)
let pos_compunit = pos_out outchan in
output_value outchan compunit;
diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index 87dcb1d6b..365286d55 100644
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -20,8 +20,8 @@ open Instruct
type reloc_info =
Reloc_literal of structured_constant (* structured constant *)
- | Reloc_getglobal of Ident.t (* reference to a global *)
- | Reloc_setglobal of Ident.t (* definition of a global *)
+ | Reloc_getglobal of Ident.t (* reference to a global *)
+ | Reloc_setglobal of Ident.t (* definition of a global *)
| Reloc_primitive of string (* C primitive number *)
(* Descriptor for compilation units *)
@@ -34,7 +34,8 @@ type compilation_unit =
cu_interface: Digest.t; (* CRC of interface implemented *)
cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
cu_primitives: string list; (* Primitives declared inside *)
- mutable cu_force_link: bool } (* Must be linked even if unref'ed *)
+ mutable cu_force_link: bool; (* Must be linked even if unref'ed *)
+ cu_events: debug_event list } (* Debugging events *)
(* Format of a .cmo file:
magic number (Config.cmo_magic_number)
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index f3d7c9e7a..d86157ba3 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -13,6 +13,23 @@
open Lambda
+type compilation_env =
+ { ce_stack: int Ident.tbl;
+ ce_heap: int Ident.tbl }
+
+type debug_event =
+ { mutable ev_pos: int; (* Position in bytecode *)
+ ev_file: string; (* Source file name *)
+ ev_char: int; (* Location in source file *)
+ ev_kind: debug_event_kind; (* Before/after event *)
+ ev_typenv: Env.summary; (* Typing environment *)
+ ev_compenv: compilation_env; (* Compilation environment *)
+ ev_stacksize: int } (* Size of stack frame *)
+
+and debug_event_kind =
+ Event_before
+ | Event_after of Types.type_expr
+
type label = int (* Symbolic code labels *)
type instruction =
@@ -61,6 +78,7 @@ type instruction =
| Koffsetint of int
| Koffsetref of int
| Kgetmethod
+ | Kevent of debug_event
| Kstop
let immed_min = -0x40000000
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index 5aabce887..1958551ff 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -15,7 +15,36 @@
open Lambda
-type label = int (* Symbolic code labels *)
+(* Structure of compilation environments *)
+
+type compilation_env =
+ { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
+ ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *)
+
+(* The ce_stack component gives locations of variables residing
+ in the stack. The locations are offsets w.r.t. the origin of the
+ stack frame.
+ The ce_heap component gives the positions of variables residing in the
+ heap-allocated environment. *)
+
+(* Debugging events *)
+
+type debug_event =
+ { mutable ev_pos: int; (* Position in bytecode *)
+ ev_file: string; (* Source file name *)
+ ev_char: int; (* Location in source file *)
+ ev_kind: debug_event_kind; (* Before/after event *)
+ ev_typenv: Env.summary; (* Typing environment *)
+ ev_compenv: compilation_env; (* Compilation environment *)
+ ev_stacksize: int } (* Size of stack frame *)
+
+and debug_event_kind =
+ Event_before
+ | Event_after of Types.type_expr
+
+(* Abstract machine instructions *)
+
+type label = int (* Symbolic code labels *)
type instruction =
Klabel of label
@@ -63,6 +92,7 @@ type instruction =
| Koffsetint of int
| Koffsetref of int
| Kgetmethod
+ | Kevent of debug_event
| Kstop
val immed_min: int
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 863a4439c..825389866 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -92,6 +92,7 @@ type lambda =
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
| Lsend of lambda * lambda * lambda list
+ | Levent of lambda * lambda_event
and lambda_switch =
{ sw_numconsts: int;
@@ -100,6 +101,15 @@ and lambda_switch =
sw_blocks: (int * lambda) list;
sw_checked: bool }
+and lambda_event =
+ { lev_loc: int;
+ lev_kind: lambda_event_kind;
+ lev_env: Env.summary }
+
+and lambda_event_kind =
+ Lev_before
+ | Lev_after of Types.type_expr
+
let const_unit = Const_pointer 0
let lambda_unit = Lconst const_unit
@@ -165,6 +175,8 @@ let free_variables l =
fv := IdentSet.add id !fv; freevars e
| Lsend (met, obj, args) ->
List.iter freevars (met::obj::args)
+ | Levent (lam, evt) ->
+ freevars lam
in freevars l; !fv
(* Check if an action has a "when" guard *)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 202d3e0b4..04aad3808 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -92,6 +92,7 @@ type lambda =
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
| Lsend of lambda * lambda * lambda list
+ | Levent of lambda * lambda_event
and lambda_switch =
{ sw_numconsts: int; (* Number of integer cases *)
@@ -100,6 +101,15 @@ and lambda_switch =
sw_blocks: (int * lambda) list; (* Tag block cases *)
sw_checked: bool } (* True if bound checks needed *)
+and lambda_event =
+ { lev_loc: int;
+ lev_kind: lambda_event_kind;
+ lev_env: Env.summary }
+
+and lambda_event_kind =
+ Lev_before
+ | Lev_after of Types.type_expr
+
val const_unit: structured_constant
val lambda_unit: lambda
val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 56b15763f..02882b96b 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -95,6 +95,7 @@ let instruction = function
| Koffsetref n -> print_string "\toffsetref "; print_int n
| Kgetmethod -> print_string "\tgetmethod"
| Kstop -> print_string "\tstop"
+ | Kevent ev -> print_string "\tevent "; print_int ev.ev_char
let rec instruction_list = function
[] -> ()
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index fa7135ef2..93700a444 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -258,6 +258,17 @@ let rec lambda = function
List.iter (fun l -> print_space(); lambda l) largs;
print_string ")";
close_box()
+ | Levent(lam, ev) ->
+ open_hovbox 2;
+ begin match ev.lev_kind with
+ Lev_before -> print_string "(before "
+ | Lev_after _ -> print_string "(after "
+ end;
+ print_int ev.lev_loc;
+ print_space();
+ lambda lam;
+ print_string ")";
+ close_box()
and sequence = function
Lsequence(l1, l2) ->
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 32b5ab74e..a4fff40b8 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -75,6 +75,8 @@ let rec eliminate_ref id = function
| Lsend(m, o, el) ->
Lsend(eliminate_ref id m, eliminate_ref id o,
List.map (eliminate_ref id) el)
+ | Levent(l, ev) ->
+ Levent(eliminate_ref id l, ev)
(* Simplification of lets *)
@@ -130,6 +132,7 @@ let simplify_lambda lam =
v's refcount *)
count l
| Lsend(m, o, ll) -> List.iter count (m::o::ll)
+ | Levent(l, ev) -> count l
in
count lam;
(* Second pass: remove Lalias bindings of unused variables,
@@ -188,5 +191,6 @@ let simplify_lambda lam =
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
| Lassign(v, l) -> Lassign(v, simplif l)
| Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll)
+ | Levent(l, ev) -> Levent(simplif l, ev)
in
simplif lam
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 9974aa2d2..6ba9278c6 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -209,9 +209,11 @@ let init_toplevel () =
(* Find the value of a global identifier *)
+let get_global_position id = slot_for_getglobal id
+
let get_global_value id =
(Meta.global_data()).(slot_for_getglobal id)
-and assign_global_value id v =
+let assign_global_value id v =
(Meta.global_data()).(slot_for_getglobal id) <- v
(* Save and restore the current state *)
diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli
index 29dcc4b67..5850f2f3e 100644
--- a/bytecomp/symtable.mli
+++ b/bytecomp/symtable.mli
@@ -30,6 +30,7 @@ val init_toplevel: unit -> unit
val update_global_table: unit -> unit
val get_global_value: Ident.t -> Obj.t
val assign_global_value: Ident.t -> Obj.t -> unit
+val get_global_position: Ident.t -> int
type global_map
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 4a02bae2f..8c15ff8f0 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -300,6 +300,22 @@ let rec name_pattern default = function
| Tpat_alias(p, id) -> id
| _ -> name_pattern default rem
+(* Insertion of debugging events *)
+
+let event_before exp lam =
+ if !Clflags.debug
+ then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_start;
+ lev_kind = Lev_before;
+ lev_env = Env.summary exp.exp_env})
+ else lam
+
+let event_after exp lam =
+ if !Clflags.debug
+ then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_end;
+ lev_kind = Lev_after exp.exp_type;
+ lev_env = Env.summary exp.exp_env})
+ else lam
+
(* Translation of expressions *)
let rec transl_exp e =
@@ -313,7 +329,7 @@ let rec transl_exp e =
| Texp_constant cst ->
Lconst(Const_base cst)
| Texp_let(rec_flag, pat_expr_list, body) ->
- transl_let rec_flag pat_expr_list (transl_exp body)
+ transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
| Texp_function pat_expr_list ->
let (kind, params, body) =
transl_function e.exp_loc !Clflags.native_code pat_expr_list in
@@ -322,14 +338,15 @@ let rec transl_exp e =
when List.length args = p.prim_arity ->
Lprim(transl_prim p args, transl_list args)
| Texp_apply(funct, args) ->
- begin match transl_exp funct with
- Lapply(lfunct, largs) ->
- Lapply(lfunct, largs @ transl_list args)
- | Lsend(lmet, lobj, largs) ->
- Lsend(lmet, lobj, largs @ transl_list args)
- | lexp ->
- Lapply(lexp, transl_list args)
- end
+ let lam =
+ match transl_exp funct with
+ Lsend(lmet, lobj, largs) ->
+ Lsend(lmet, lobj, largs @ transl_list args)
+ | Levent(Lsend(lmet, lobj, largs), _) ->
+ Lsend(lmet, lobj, largs @ transl_list args)
+ | lexp ->
+ Lapply(lexp, transl_list args) in
+ event_after e lam
| Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list) ->
Matching.for_multiple_match e.exp_loc
(transl_list argl) (transl_cases pat_expr_list)
@@ -419,19 +436,24 @@ let rec transl_exp e =
fill_fields 1 (List.tl expr_list))
end
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
- Lifthenelse(transl_exp cond, transl_exp ifso, transl_exp ifnot)
+ Lifthenelse(transl_exp cond,
+ event_before ifso (transl_exp ifso),
+ event_before ifnot (transl_exp ifnot))
| Texp_ifthenelse(cond, ifso, None) ->
- Lifthenelse(transl_exp cond, transl_exp ifso, lambda_unit)
+ Lifthenelse(transl_exp cond,
+ event_before ifso (transl_exp ifso),
+ lambda_unit)
| Texp_sequence(expr1, expr2) ->
- Lsequence(transl_exp expr1, transl_exp expr2)
+ Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
| Texp_while(cond, body) ->
- Lwhile(transl_exp cond, transl_exp body)
+ Lwhile(transl_exp cond, event_before body (transl_exp body))
| Texp_for(param, low, high, dir, body) ->
- Lfor(param, transl_exp low, transl_exp high, dir, transl_exp body)
+ Lfor(param, transl_exp low, transl_exp high, dir,
+ event_before body (transl_exp body))
| Texp_when(cond, body) ->
Lifthenelse(transl_exp cond, transl_exp body, Lstaticfail)
| Texp_send(expr, met) ->
- Lsend(Lvar (meth met), transl_exp expr, [])
+ event_after e (Lsend(Lvar (meth met), transl_exp expr, []))
| Texp_new cl ->
Lprim(Pfield 0, [transl_path cl])
| Texp_instvar(path_self, path) ->
@@ -454,7 +476,9 @@ and transl_list expr_list =
List.map transl_exp expr_list
and transl_cases pat_expr_list =
- List.map (fun (pat, expr) -> (pat, transl_exp expr)) pat_expr_list
+ List.map
+ (fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
+ pat_expr_list
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
diff --git a/byterun/Makefile b/byterun/Makefile
index 5f69ea498..2f13366b9 100644
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -9,7 +9,7 @@ OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \
fail.o signals.o printexc.o \
compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \
hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \
- lexing.o callback.o
+ lexing.o callback.o debugger.o
DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
@@ -63,6 +63,7 @@ prims.c : primitives
opnames.h : instruct.h
sed -e '/\/\*/d' \
+ -e '/^#/d' \
-e 's/enum /char * names_of_/' \
-e 's/{$$/[] = {/' \
-e 's/\([A-Z][A-Z_0-9]*\)/"\1"/g' instruct.h > opnames.h
diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 363fbbb5a..5713330d6 100644
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -11,14 +11,51 @@
/* $Id$ */
-/* Translate a block of bytecode (endianness switch, threading). */
+/* Handling of blocks of bytecode (endianness switch, threading). */
#include "config.h"
+#include "debugger.h"
#include "fix_code.h"
+#include "memory.h"
#include "misc.h"
#include "mlvalues.h"
#include "instruct.h"
#include "reverse.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+code_t start_code;
+asize_t code_size;
+unsigned char * saved_code;
+
+/* Read the main bytecode block from a file */
+
+void load_code(fd, len)
+ int fd;
+ asize_t len;
+{
+ int i;
+
+ code_size = len;
+ start_code = (code_t) stat_alloc(code_size);
+ if (read(fd, (char *) start_code, code_size) != code_size)
+ fatal_error("Fatal error: truncated bytecode file.\n");
+#ifdef BIG_ENDIAN
+ fixup_endianness(start_code, code_size);
+#endif
+ if (debugger_in_use) {
+ len /= sizeof(opcode_t);
+ saved_code = (unsigned char *) stat_alloc(len);
+ for (i = 0; i < len; i++) saved_code[i] = start_code[i];
+ }
+#ifdef THREADED_CODE
+ /* Better to thread now than at the beginning of interprete(),
+ since the debugger interface needs to perform SET_EVENT requests
+ on the code. */
+ thread_code(start_code, code_size);
+#endif
+}
/* This code is needed only if the processor is big endian */
@@ -86,4 +123,16 @@ void thread_code (code_t code, asize_t len)
Assert(p == code + len);
}
-#endif /* THREAD_CODE */
+#endif /* THREADED_CODE */
+
+void set_instruction(pos, instr)
+ code_t pos;
+ opcode_t instr;
+{
+#ifdef THREADED_CODE
+ *pos = (opcode_t)((unsigned long)(instr_table[instr]));
+#else
+ *pos = instr;
+#endif
+}
+
diff --git a/byterun/fix_code.h b/byterun/fix_code.h
index c6ff34d27..b26f0fc71 100644
--- a/byterun/fix_code.h
+++ b/byterun/fix_code.h
@@ -11,7 +11,7 @@
/* $Id$ */
-/* Translate a block of bytecode (endianness switch, threading). */
+/* Handling of blocks of bytecode (endianness switch, threading). */
#ifndef _fix_code_
#define _fix_code_
@@ -21,12 +21,17 @@
#include "misc.h"
#include "mlvalues.h"
+extern code_t start_code;
+extern asize_t code_size;
+extern unsigned char * saved_code;
#ifdef THREADED_CODE
extern void ** instr_table;
#endif
+void load_code P((int fd, asize_t len));
void fixup_endianness P((code_t code, asize_t len));
void thread_code P((code_t code, asize_t len));
+void set_instruction P((code_t pos, opcode_t instr));
#endif
diff --git a/byterun/instruct.h b/byterun/instruct.h
index 68695f9f3..2f2010227 100644
--- a/byterun/instruct.h
+++ b/byterun/instruct.h
@@ -43,5 +43,7 @@ enum instructions {
EQ, NEQ, LTINT, LEINT, GTINT, GEINT,
OFFSETINT, OFFSETREF,
GETMETHOD,
- STOP
+ STOP, EVENT, BREAK
};
+
+#define Last_instruction BREAK
diff --git a/byterun/interp.c b/byterun/interp.c
index 20c79add2..5729d9879 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -15,6 +15,7 @@
#include "alloc.h"
#include "callback.h"
+#include "debugger.h"
#include "fail.h"
#include "fix_code.h"
#include "instrtrace.h"
@@ -65,6 +66,24 @@ sp is a local copy of the global variable extern_sp. */
#define Setup_for_c_call { *--sp = env; extern_sp = sp; }
#define Restore_after_c_call { sp = extern_sp; env = *sp++; }
+/* Debugger interface */
+
+#define Setup_for_debugger \
+ { sp -= 4; \
+ sp[0] = accu; sp[1] = (value)(pc - 1); \
+ sp[2] = env; sp[3] = Val_long(extra_args); \
+ extern_sp = sp; }
+#define Restore_after_debugger { sp += 4; }
+
+#ifdef THREADED_CODE
+#define Restart_curr_instr \
+ goto *(jumptable[saved_code[pc - 1 - start_code]])
+#else
+#define Restart_curr_instr \
+ curr_instr = saved_code[pc - 1 - start_code]; \
+ goto dispatch_instr
+#endif
+
/* Register optimization.
Many compilers underestimate the use of the local variables representing
the abstract machine registers, and don't put them in hardware registers,
@@ -133,6 +152,7 @@ value interprete(prog, prog_size)
int initial_callback_depth;
struct longjmp_buffer raise_buf;
value * modify_dest, modify_newval;
+ opcode_t curr_instr;
#ifdef THREADED_CODE
static void * jumptable[] = {
@@ -140,11 +160,15 @@ value interprete(prog, prog_size)
};
#endif
+ if (prog == NULL) { /* Interpreter is initializing */
#ifdef THREADED_CODE
- if (prog[0] <= STOP) {
instr_table = jumptable;
- thread_code(prog, prog_size);
+#endif
+ return Val_unit;
}
+
+#ifdef THREADED_CODE
+ if (prog[0] <= STOP) thread_code(prog, prog_size);
#endif
sp = extern_sp;
@@ -160,6 +184,7 @@ value interprete(prog, prog_size)
local_roots = initial_local_roots;
callback_depth = initial_callback_depth;
accu = exn_bucket;
+ sp = extern_sp;
goto raise_exception;
}
external_raise = &raise_buf;
@@ -182,7 +207,9 @@ value interprete(prog, prog_size)
Assert(sp >= stack_low);
Assert(sp <= stack_high);
#endif
- switch(*pc++) {
+ curr_instr = *pc++;
+ dispatch_instr:
+ switch(curr_instr) {
#endif
/* Basic stack operations */
@@ -657,8 +684,13 @@ value interprete(prog, prog_size)
sp += 4;
Next;
- Instruct(RAISE): /* arg */
+ Instruct(RAISE):
raise_exception:
+ if (trapsp >= trap_barrier) {
+ Setup_for_debugger;
+ debugger(TRAP_BARRIER);
+ Restore_after_debugger;
+ }
sp = trapsp;
if (sp >= stack_high - initial_sp_offset) {
exn_bucket = accu;
@@ -863,13 +895,27 @@ value interprete(prog, prog_size)
accu = Lookup(sp[0], accu);
Next;
-/* Machine control */
+/* Debugging and machine control */
Instruct(STOP):
external_raise = initial_external_raise;
extern_sp = sp;
return accu;
+ Instruct(EVENT):
+ if (--event_count == 0) {
+ Setup_for_debugger;
+ debugger(EVENT_COUNT);
+ Restore_after_debugger;
+ }
+ Restart_curr_instr;
+
+ Instruct(BREAK):
+ Setup_for_debugger;
+ debugger(BREAKPOINT);
+ Restore_after_debugger;
+ Restart_curr_instr;
+
#ifndef THREADED_CODE
default:
fatal_error_arg("Fatal error: bad opcode (%lx)\n", (char *) *(pc-1));
diff --git a/byterun/stacks.c b/byterun/stacks.c
index 40aba8cdd..cc059b61f 100644
--- a/byterun/stacks.c
+++ b/byterun/stacks.c
@@ -25,6 +25,7 @@ value * stack_high;
value * stack_threshold;
value * extern_sp;
value * trapsp;
+value * trap_barrier;
value global_data;
void init_stack()
@@ -34,6 +35,7 @@ void init_stack()
stack_threshold = stack_low + Stack_threshold / sizeof (value);
extern_sp = stack_high;
trapsp = stack_high;
+ trap_barrier = stack_high + 1;
}
void realloc_stack()
@@ -61,6 +63,7 @@ void realloc_stack()
(stack_high - extern_sp) * sizeof(value));
stat_free((char *) stack_low);
trapsp = (value *) shift(trapsp);
+ trap_barrier = (value *) shift(trap_barrier);
for (p = trapsp; p < new_high; p = Trap_link(p))
Trap_link(p) = (value *) shift(Trap_link(p));
stack_low = new_low;
diff --git a/byterun/stacks.h b/byterun/stacks.h
index 637fc16d6..a695f3243 100644
--- a/byterun/stacks.h
+++ b/byterun/stacks.h
@@ -26,6 +26,7 @@ extern value * stack_high;
extern value * stack_threshold;
extern value * extern_sp;
extern value * trapsp;
+extern value * trap_barrier;
#define Trap_pc(tp) (((code_t *)(tp))[0])
#define Trap_link(tp) (((value **)(tp))[1])
diff --git a/byterun/startup.c b/byterun/startup.c
index 7d611d642..ff31db569 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -22,6 +22,7 @@
#include <unistd.h>
#endif
#include "alloc.h"
+#include "debugger.h"
#include "exec.h"
#include "fail.h"
#include "fix_code.h"
@@ -226,15 +227,14 @@ void caml_main(argv)
verbose_init);
init_stack();
init_atoms();
+ /* Initialize the interpreter */
+ interprete(NULL, 0);
+ /* Initialize the debugger, if needed */
+ debugger_init();
/* Load the code */
lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size
+ trail.symbol_size + trail.debug_size), 2);
- start_code = (code_t) stat_alloc(trail.code_size);
- if (read(fd, (char *) start_code, trail.code_size) != trail.code_size)
- fatal_error("Fatal error: truncated bytecode file.\n");
-#ifdef ARCH_BIG_ENDIAN
- fixup_endianness(start_code, trail.code_size);
-#endif
+ load_code(fd, trail.code_size);
/* Load the globals */
{ struct channel * chan;
Push_roots(r, 1);
@@ -246,10 +246,13 @@ void caml_main(argv)
}
/* Ensure that the globals are in the major heap. */
oldify(global_data, &global_data);
- /* Run the code */
+ /* Record the command-line arguments */
sys_init(argv + pos);
+ /* Execute the program */
+ debugger(PROGRAM_START);
interprete(start_code, trail.code_size);
} else {
+ debugger(UNCAUGHT_EXC);
fatal_uncaught_exception(exn_bucket);
}
}
diff --git a/byterun/sys.c b/byterun/sys.c
index 97897d26e..313912706 100644
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -27,6 +27,7 @@
#include <unistd.h>
#endif
#include "alloc.h"
+#include "debugger.h"
#include "fail.h"
#include "instruct.h"
#include "mlvalues.h"
@@ -90,6 +91,7 @@ void sys_error(arg)
value sys_exit(retcode) /* ML */
value retcode;
{
+ debugger(PROGRAM_EXIT);
#ifdef HAS_UI
ui_exit(Int_val(retcode));
#else
diff --git a/driver/main.ml b/driver/main.ml
index d695cfecf..ab39a4053 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -60,6 +60,7 @@ let main () =
"-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts),
"<opt> Pass option <opt> to the C compiler and linker";
"-custom", Arg.Set custom_runtime, " Link in custom mode";
+ "-g", Arg.Set debug, " Save debugging information";
"-i", Arg.Set print_types, " Print the types";
"-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
"<dir> Add <dir> to the list of include directories";
diff --git a/typing/env.ml b/typing/env.ml
index d52e42464..9cb106d74 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -29,6 +29,16 @@ type error =
exception Error of error
+type summary =
+ Env_empty
+ | Env_value of summary * Ident.t * value_description
+ | Env_type of summary * Ident.t * type_declaration
+ | Env_exception of summary * Ident.t * exception_declaration
+ | Env_module of summary * Ident.t * module_type
+ | Env_modtype of summary * Ident.t * modtype_declaration
+ | Env_class of summary * Ident.t * class_type
+ | Env_open of summary * Path.t
+
type t = {
values: (Path.t * value_description) Ident.tbl;
constrs: constructor_description Ident.tbl;
@@ -37,7 +47,8 @@ type t = {
modules: (Path.t * module_type) Ident.tbl;
modtypes: (Path.t * modtype_declaration) Ident.tbl;
components: (Path.t * module_components) Ident.tbl;
- classes: (Path.t * class_type) Ident.tbl
+ classes: (Path.t * class_type) Ident.tbl;
+ summary: summary
}
and module_components =
@@ -66,7 +77,8 @@ let empty = {
values = Ident.empty; constrs = Ident.empty;
labels = Ident.empty; types = Ident.empty;
modules = Ident.empty; modtypes = Ident.empty;
- components = Ident.empty; classes = Ident.empty }
+ components = Ident.empty; classes = Ident.empty;
+ summary = Env_empty }
(* Persistent structure descriptions *)
@@ -174,6 +186,27 @@ and find_type = find (fun env -> env.types) (fun sc -> sc.comp_types)
and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
and find_class = find (fun env -> env.classes) (fun sc -> sc.comp_classes)
+let find_module path env =
+ match path with
+ Pident id ->
+ begin try
+ let (p, data) = Ident.find_same id env.modules
+ in data
+ with Not_found ->
+ if Ident.persistent id
+ then Tmty_signature((find_pers_struct (Ident.name id)).ps_sig)
+ else raise Not_found
+ end
+ | Pdot(p, s, pos) ->
+ begin match find_module_descr p env with
+ Structure_comps c ->
+ let (data, pos) = Tbl.find s c.comp_modules in data
+ | Functor_comps f ->
+ raise Not_found
+ end
+ | Papply(p1, p2) ->
+ raise Not_found (* not right *)
+
(* Lookup by name *)
let rec lookup_module_descr lid env =
@@ -432,7 +465,8 @@ and store_value id path decl env =
modules = env.modules;
modtypes = env.modtypes;
components = env.components;
- classes = env.classes }
+ classes = env.classes;
+ summary = Env_value(env.summary, id, decl) }
and store_type id path info env =
{ values = env.values;
@@ -452,7 +486,8 @@ and store_type id path info env =
modules = env.modules;
modtypes = env.modtypes;
components = env.components;
- classes = env.classes }
+ classes = env.classes;
+ summary = Env_type(env.summary, id, info) }
and store_exception id path decl env =
{ values = env.values;
@@ -462,7 +497,8 @@ and store_exception id path decl env =
modules = env.modules;
modtypes = env.modtypes;
components = env.components;
- classes = env.classes }
+ classes = env.classes;
+ summary = Env_exception(env.summary, id, decl) }
and store_module id path mty env =
{ values = env.values;
@@ -474,7 +510,8 @@ and store_module id path mty env =
components =
Ident.add id (path, components_of_module env Subst.identity path mty)
env.components;
- classes = env.classes }
+ classes = env.classes;
+ summary = Env_module(env.summary, id, mty) }
and store_modtype id path info env =
{ values = env.values;
@@ -484,7 +521,8 @@ and store_modtype id path info env =
modules = env.modules;
modtypes = Ident.add id (path, info) env.modtypes;
components = env.components;
- classes = env.classes }
+ classes = env.classes;
+ summary = Env_modtype(env.summary, id, info) }
and store_components id path comps env =
{ values = env.values;
@@ -494,7 +532,8 @@ and store_components id path comps env =
modules = env.modules;
modtypes = env.modtypes;
components = Ident.add id (path, comps) env.components;
- classes = env.classes }
+ classes = env.classes;
+ summary = env.summary }
and store_class id path desc env =
{ values = env.values;
@@ -504,7 +543,8 @@ and store_class id path desc env =
modules = env.modules;
modtypes = env.modtypes;
components = env.components;
- classes = Ident.add id (path, desc) env.classes }
+ classes = Ident.add id (path, desc) env.classes;
+ summary = Env_class(env.summary, id, desc) }
(* Memoized function to compute the components of a functor application
in a path. *)
@@ -580,28 +620,38 @@ let open_signature root sg env =
(* First build the paths and substitution *)
let (pl, sub) = prefix_idents root 0 Subst.identity sg in
(* Then enter the components in the environment after substitution *)
- List.fold_left2
- (fun env item p ->
- match item with
- Tsig_value(id, decl) ->
- store_value (Ident.hide id) p
- (Subst.value_description sub decl) env
- | Tsig_type(id, decl) ->
- store_type (Ident.hide id) p
- (Subst.type_declaration sub decl) env
- | Tsig_exception(id, decl) ->
- store_exception (Ident.hide id) p
- (Subst.exception_declaration sub decl) env
- | Tsig_module(id, mty) ->
- store_module (Ident.hide id) p (Subst.modtype sub mty) env
- | Tsig_modtype(id, decl) ->
- store_modtype (Ident.hide id) p
- (Subst.modtype_declaration sub decl) env
- | Tsig_class(id, decl) ->
- store_class (Ident.hide id) p
- (Subst.class_type sub decl) env)
- env sg pl
-
+ let newenv =
+ List.fold_left2
+ (fun env item p ->
+ match item with
+ Tsig_value(id, decl) ->
+ store_value (Ident.hide id) p
+ (Subst.value_description sub decl) env
+ | Tsig_type(id, decl) ->
+ store_type (Ident.hide id) p
+ (Subst.type_declaration sub decl) env
+ | Tsig_exception(id, decl) ->
+ store_exception (Ident.hide id) p
+ (Subst.exception_declaration sub decl) env
+ | Tsig_module(id, mty) ->
+ store_module (Ident.hide id) p (Subst.modtype sub mty) env
+ | Tsig_modtype(id, decl) ->
+ store_modtype (Ident.hide id) p
+ (Subst.modtype_declaration sub decl) env
+ | Tsig_class(id, decl) ->
+ store_class (Ident.hide id) p
+ (Subst.class_type sub decl) env)
+ env sg pl in
+ { values = newenv.values;
+ constrs = newenv.constrs;
+ labels = newenv.labels;
+ types = newenv.types;
+ modules = newenv.modules;
+ modtypes = newenv.modtypes;
+ components = newenv.components;
+ classes = newenv.classes;
+ summary = Env_open(env.summary, root) }
+
(* Open a signature from a file *)
let open_pers_signature name env =
@@ -639,6 +689,10 @@ let initial = Predef.build_initial_env add_type add_exception empty
let imported_units() = !imported_units
+(* Return the environment summary *)
+
+let summary env = env.summary
+
(* Error report *)
let report_error = function
diff --git a/typing/env.mli b/typing/env.mli
index fe12606ef..3fa55f24d 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -24,6 +24,7 @@ val initial: t
val find_value: Path.t -> t -> value_description
val find_type: Path.t -> t -> type_declaration
+val find_module: Path.t -> t -> module_type
val find_modtype: Path.t -> t -> modtype_declaration
val find_class: Path.t -> t -> class_type
@@ -84,6 +85,21 @@ val save_signature: signature -> string -> string -> Digest.t
val imported_units: unit -> (string * Digest.t) list
+(* Summaries -- compact representation of an environment, to be
+ exported in debugging information. *)
+
+type summary =
+ Env_empty
+ | Env_value of summary * Ident.t * value_description
+ | Env_type of summary * Ident.t * type_declaration
+ | Env_exception of summary * Ident.t * exception_declaration
+ | Env_module of summary * Ident.t * module_type
+ | Env_modtype of summary * Ident.t * modtype_declaration
+ | Env_class of summary * Ident.t * class_type
+ | Env_open of summary * Path.t
+
+val summary: t -> summary
+
(* Error report *)
type error =
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 160f59117..6ac450029 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -23,6 +23,7 @@ and object_name = ref ("camlprog" ^ Config.ext_obj) (* -o *)
and include_dirs = ref ([] : string list)(* -I *)
and print_types = ref false (* -i *)
and make_archive = ref false (* -a *)
+and debug = ref false (* -g *)
and fast = ref false (* -unsafe *)
and link_everything = ref false (* -linkall *)
and custom_runtime = ref false (* -custom *)
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 13:05:18 +0000