diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/bytegen.ml | 41 | ||||
| -rw-r--r-- | bytecomp/bytelink.ml | 49 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 18 | ||||
| -rw-r--r-- | bytecomp/emitcode.mli | 7 | ||||
| -rw-r--r-- | bytecomp/instruct.ml | 18 | ||||
| -rw-r--r-- | bytecomp/instruct.mli | 32 | ||||
| -rw-r--r-- | bytecomp/lambda.ml | 12 | ||||
| -rw-r--r-- | bytecomp/lambda.mli | 10 | ||||
| -rw-r--r-- | bytecomp/printinstr.ml | 1 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 11 | ||||
| -rw-r--r-- | bytecomp/simplif.ml | 4 | ||||
| -rw-r--r-- | bytecomp/symtable.ml | 4 | ||||
| -rw-r--r-- | bytecomp/symtable.mli | 1 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 56 |
14 files changed, 216 insertions, 48 deletions
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 |