From ed1f32134283d3cd4f939a26dfd99992ec48da86 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 8 Oct 2015 13:27:50 +0200 Subject: Moved expandation of debug information to Asmexpandaux. The function is generalized to work for all backends and takes as additional arguments functions for the printing of the simple instructions and the translation function for the arguments. --- backend/Asmexpandaux.ml | 69 +++++++++++++++++++++++++++++++++++++++++++++++ powerpc/Asmexpand.ml | 71 ++++--------------------------------------------- 2 files changed, 74 insertions(+), 66 deletions(-) diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index 6ce6c005..5c3ac381 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -55,3 +55,72 @@ let get_current_function () = let fn = !current_function in set_current_function dummy_function; {fn with fn_code = c} + +(* Expand function for debug information *) + +let expand_scope id lbl oldscopes newscopes = + let opening = List.filter (fun a -> not (List.mem a oldscopes)) newscopes + and closing = List.filter (fun a -> not (List.mem a newscopes)) oldscopes in + List.iter (fun i -> Debug.open_scope id i lbl) opening; + List.iter (fun i -> Debug.close_scope id i lbl) closing + + +let expand_debug id annot simple l = + let get_lbl = function + | None -> + let lbl = new_label () in + emit (Plabel lbl); + lbl + | Some lbl -> lbl in + let rec aux lbl scopes = function + | [] -> let lbl = get_lbl lbl in + Debug.function_end id lbl + | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> + let kind = (P.to_int kind) in + begin + match kind with + | 1-> + emit i;aux lbl scopes rest + | 2 -> + aux lbl scopes rest + | 3 -> + begin + match annot args with + | Some a -> + let lbl = get_lbl lbl in + Debug.start_live_range (id,txt) lbl a; + aux (Some lbl) scopes rest + | None -> aux lbl scopes rest + end + | 4 -> + let lbl = get_lbl lbl in + Debug.end_live_range (id,txt) lbl; + aux (Some lbl) scopes rest + | 5 -> + begin + match annot args with + | Some a-> + Debug.stack_variable (id,txt) a; + aux lbl scopes rest + | _ -> aux lbl scopes rest + end + | 6 -> + let lbl = get_lbl lbl in + let scopes' = List.map (function BA_int x -> Int32.to_int (camlint_of_coqint x) | _ -> assert false) args in + expand_scope id lbl scopes scopes'; + aux (Some lbl) scopes' rest + | _ -> + aux None scopes rest + end + | i::rest -> simple i; aux None scopes rest in + (* We need to move all closing debug annotations before the last real statement *) + let rec move_debug acc bcc = function + | (Pbuiltin(EF_debug (kind,_,_),_,_) as i)::rest -> + let kind = (P.to_int kind) in + if kind = 1 then + move_debug acc (i::bcc) rest (* Do not move debug line *) + else + move_debug (i::acc) bcc rest (* Move the debug annotations forward *) + | b::rest -> List.rev ((List.rev (b::bcc)@List.rev acc)@rest) (* We found the first non debug location *) + | [] -> List.rev acc (* This actually can never happen *) in + aux None [] (move_debug [] [] (List.rev l)) diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index a2cfb136..878c7e5d 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -668,7 +668,7 @@ let preg_to_dwarf_int = function let translate_annot annot = let rec aux = function - | BA x -> Some (BA (preg_to_dwarf_int x)) + | BA x -> Some (1,BA (preg_to_dwarf_int x)) | BA_int _ | BA_long _ | BA_float _ @@ -676,11 +676,11 @@ let translate_annot annot = | BA_loadglobal _ | BA_addrglobal _ | BA_loadstack _ -> None - | BA_addrstack ofs -> Some (BA_addrstack ofs) + | BA_addrstack ofs -> Some (1,BA_addrstack ofs) | BA_splitlong (hi,lo) -> begin match (aux hi,aux lo) with - | Some hi ,Some lo -> Some (BA_splitlong (hi,lo)) + | Some (_,hi) ,Some (_,lo) -> Some (1,BA_splitlong (hi,lo)) | _,_ -> None end in (match annot with @@ -692,73 +692,12 @@ let expand_scope id lbl oldscopes newscopes = and closing = List.filter (fun a -> not (List.mem a newscopes)) oldscopes in List.iter (fun i -> Debug.open_scope id i lbl) opening; List.iter (fun i -> Debug.close_scope id i lbl) closing - -let expand_instruction id l = - let get_lbl = function - | None -> - let lbl = new_label () in - emit (Plabel lbl); - lbl - | Some lbl -> lbl in - let rec aux lbl scopes = function - | [] -> let lbl = get_lbl lbl in - Debug.function_end id lbl - | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> - let kind = (P.to_int kind) in - begin - match kind with - | 1-> - emit i;aux lbl scopes rest - | 2 -> - aux lbl scopes rest - | 3 -> - begin - match translate_annot args with - | Some a -> - let lbl = get_lbl lbl in - Debug.start_live_range (id,txt) lbl (1,a); - aux (Some lbl) scopes rest - | None -> aux lbl scopes rest - end - | 4 -> - let lbl = get_lbl lbl in - Debug.end_live_range (id,txt) lbl; - aux (Some lbl) scopes rest - | 5 -> - begin - match translate_annot args with - | Some a-> - Debug.stack_variable (id,txt) (1,a); - aux lbl scopes rest - | _ -> aux lbl scopes rest - end - | 6 -> - let lbl = get_lbl lbl in - let scopes' = List.map (function BA_int x -> Int32.to_int (camlint_of_coqint x) | _ -> assert false) args in - expand_scope id lbl scopes scopes'; - aux (Some lbl) scopes' rest - | _ -> - aux None scopes rest - end - | i::rest -> expand_instruction_simple i; aux None scopes rest in - (* We need to move all closing debug annotations before the last real statement *) - let rec move_debug acc bcc = function - | (Pbuiltin(EF_debug (kind,_,_),_,_) as i)::rest -> - let kind = (P.to_int kind) in - if kind = 1 then - move_debug acc (i::bcc) rest (* Do not move debug line *) - else - move_debug (i::acc) bcc rest (* Move the debug annotations forward *) - | b::rest -> List.rev ((List.rev (b::bcc)@List.rev acc)@rest) (* We found the first non debug location *) - | [] -> List.rev acc (* This actually can never happen *) in - aux None [] (move_debug [] [] (List.rev l)) - - + let expand_function id fn = try set_current_function fn; if !Clflags.option_g then - expand_instruction id fn.fn_code + expand_debug id translate_annot expand_instruction_simple fn.fn_code else List.iter expand_instruction_simple fn.fn_code; Errors.OK (get_current_function ()) -- cgit