diff options
| -rw-r--r-- | bytecomp/bytegen.ml | 25 | ||||
| -rw-r--r-- | bytecomp/bytegen.mli | 2 | ||||
| -rw-r--r-- | bytecomp/bytelibrarian.ml | 7 | ||||
| -rw-r--r-- | bytecomp/bytelink.ml | 18 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 27 | ||||
| -rw-r--r-- | bytecomp/emitcode.mli | 3 | ||||
| -rw-r--r-- | bytecomp/instruct.ml | 2 | ||||
| -rw-r--r-- | bytecomp/instruct.mli | 2 | ||||
| -rw-r--r-- | bytecomp/lambda.ml | 1 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 2 |
10 files changed, 64 insertions, 25 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 5624d4715..7f33bb7d0 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -123,6 +123,10 @@ and sz_staticfail = ref 0 let functions_to_compile = (Stack.create () : (Ident.t list * lambda * label * Ident.t list) Stack.t) +(* Name of current compilation unit (for debugging events) *) + +let compunit_name = ref "" + (* Compile an expression. The value of the expression is left in the accumulator. env = compilation environment @@ -395,7 +399,7 @@ let rec comp_expr env exp sz cont = | Levent(lam, lev) -> let ev = { ev_pos = 0; (* patched in emitcode *) - ev_file = !Location.input_name; + ev_module = !compunit_name; ev_char = lev.lev_loc; ev_kind = begin match lev.lev_kind with Lev_before -> Event_before @@ -413,12 +417,16 @@ let rec comp_expr env exp sz cont = | _ -> 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) + if is_tailcall cont then (* don't destroy tail call opt *) + comp_expr env lam sz cont + else begin + 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 end (* Compile a list of arguments [e1; ...; eN] to a primitive operation. @@ -485,11 +493,12 @@ let comp_remainder cont = (**** Compilation of a lambda phrase ****) -let compile_implementation expr = +let compile_implementation modulename expr = Stack.clear functions_to_compile; label_counter := 0; lbl_staticfail := 0; sz_staticfail := 0; + compunit_name := modulename; let init_code = comp_expr empty_env expr 0 [] in if Stack.length functions_to_compile > 0 then begin let lbl_init = new_label() in diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index d89781d07..1cde7e081 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -16,5 +16,5 @@ open Lambda open Instruct -val compile_implementation: lambda -> instruction list +val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index 4fc8f870c..7890ee15c 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -27,7 +27,12 @@ let copy_compunit ic oc compunit = seek_in ic compunit.cu_pos; compunit.cu_pos <- pos_out oc; compunit.cu_force_link <- !Clflags.link_everything; - copy_file_chunk ic oc compunit.cu_codesize + copy_file_chunk ic oc compunit.cu_codesize; + if compunit.cu_debug > 0 then begin + seek_in ic compunit.cu_debug; + compunit.cu_debug <- pos_out oc; + copy_file_chunk ic oc compunit.cu_debugsize + end let copy_object_file oc name = let file_name = diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 9cd416455..3e7f31e27 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -151,7 +151,10 @@ let link_compunit output_fun currpos_fun inchan file_name compunit = 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; + if !Clflags.debug && compunit.cu_debug > 0 then begin + seek_in inchan compunit.cu_debug; + record_events (currpos_fun()) (input_value inchan : debug_event list) + end; output_fun code_block; if !Clflags.link_everything then List.iter Symtable.require_primitive compunit.cu_primitives @@ -175,14 +178,15 @@ 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 currpos_fun inchan file_name) + (fun cu -> + let name = file_name ^ "(" ^ cu.cu_name ^ ")" in + try + link_compunit output_fun currpos_fun inchan name cu + with Symtable.Error msg -> + raise(Error(Symbol_error(name, msg)))) units_required; close_in inchan - with - Symtable.Error msg -> - close_in inchan; raise(Error(Symbol_error(file_name, msg))) - | x -> - close_in inchan; raise x + with x -> close_in inchan; raise x (* Link in a .cmo or .cma file *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 62fd5f1f2..76f7b52c4 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -40,7 +40,8 @@ type compilation_unit = 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 *) - cu_events: debug_event list } (* Debugging events *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) (* Format of a .cmo file: magic number (Config.cmo_magic_number) @@ -262,8 +263,8 @@ let rec emit = function emit c | Kpush :: Kgetglobal id :: Kgetfield n :: c -> out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c - | Kpush :: Kgetglobal q :: c -> - out opPUSHGETGLOBAL; slot_for_getglobal q; emit c + | Kpush :: Kgetglobal id :: c -> + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c | Kpush :: Kconst sc :: c -> begin match sc with Const_base(Const_int i) when i >= immed_min & i <= immed_max -> @@ -272,12 +273,22 @@ let rec emit = function else (out opPUSHCONSTINT; out_int i) | Const_base(Const_char c) -> out opPUSHCONSTINT; out_int(Char.code c) + | Const_pointer i -> + if i >= 0 & i <= 3 + then out (opPUSHCONST0 + i) + else (out opPUSHCONSTINT; out_int i) | Const_block(t, []) -> if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t) | _ -> out opPUSHGETGLOBAL; slot_for_literal sc end; emit c + | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: + (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c -> + emit (Kpush :: instr1 :: instr2 :: ev :: c) + | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: + (Kacc _ | Kenvacc _ | Kgetglobal _ | Kconst _ as instr) :: c -> + emit (Kpush :: instr :: ev :: c) | Kgetglobal id :: Kgetfield n :: c -> out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c (* Default case *) @@ -294,6 +305,13 @@ let to_file outchan unit_name crc_interface code = let pos_code = pos_out outchan in emit code; output outchan !out_buffer 0 !out_position; + let (pos_debug, size_debug) = + if !Clflags.debug then begin + let p = pos_out outchan in + output_value outchan !events; + (p, pos_out outchan - p) + end else + (0, 0) in let compunit = { cu_name = unit_name; cu_pos = pos_code; @@ -303,7 +321,8 @@ let to_file outchan unit_name crc_interface code = cu_imports = Env.imported_units(); cu_primitives = !Translmod.primitive_declarations; cu_force_link = false; - cu_events = !events } in + cu_debug = pos_debug; + cu_debugsize = size_debug } in init(); (* Free out_buffer and reloc_info *) Types.cleanup_abbrev (); (* Remove any cached abbreviation expansion before saving *) diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 365286d55..3ea843e2c 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -35,7 +35,8 @@ type compilation_unit = 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 *) - cu_events: debug_event list } (* Debugging events *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) (* Format of a .cmo file: magic number (Config.cmo_magic_number) diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index d86157ba3..b984ee6ed 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -19,7 +19,7 @@ type compilation_env = type debug_event = { mutable ev_pos: int; (* Position in bytecode *) - ev_file: string; (* Source file name *) + ev_module: string; (* Name of defining module *) ev_char: int; (* Location in source file *) ev_kind: debug_event_kind; (* Before/after event *) ev_typenv: Env.summary; (* Typing environment *) diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 1958551ff..97fa90a2a 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -31,7 +31,7 @@ type compilation_env = type debug_event = { mutable ev_pos: int; (* Position in bytecode *) - ev_file: string; (* Source file name *) + ev_module: string; (* Name of defining module *) ev_char: int; (* Location in source file *) ev_kind: debug_event_kind; (* Before/after event *) ev_typenv: Env.summary; (* Typing environment *) diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 825389866..0e7bcf768 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -184,6 +184,7 @@ let free_variables l = let rec is_guarded = function Lifthenelse(cond, body, Lstaticfail) -> true | Llet(str, id, lam, body) -> is_guarded body + | Levent(lam, ev) -> is_guarded lam | _ -> false let rec transl_path = function diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 8c15ff8f0..5725b4990 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -303,7 +303,7 @@ let rec name_pattern default = function (* Insertion of debugging events *) let event_before exp lam = - if !Clflags.debug + if !Clflags.debug && lam <> Lstaticfail then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_start; lev_kind = Lev_before; lev_env = Env.summary exp.exp_env}) |