diff options
84 files changed, 5968 insertions, 2375 deletions
@@ -129,10 +129,10 @@ flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beau flocq/Core/Fcore_defs.vo flocq/Core/Fcore_defs.glob flocq/Core/Fcore_defs.v.beautified: flocq/Core/Fcore_defs.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_digits.vo flocq/Core/Fcore_digits.glob flocq/Core/Fcore_digits.v.beautified: flocq/Core/Fcore_digits.v flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_float_prop.glob flocq/Core/Fcore_float_prop.v.beautified: flocq/Core/Fcore_float_prop.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo -flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FIX.glob flocq/Core/Fcore_FIX.v.beautified: flocq/Core/Fcore_FIX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_rnd_ne.vo -flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_FLT.glob flocq/Core/Fcore_FLT.v.beautified: flocq/Core/Fcore_FLT.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_rnd_ne.vo -flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLX.glob flocq/Core/Fcore_FLX.v.beautified: flocq/Core/Fcore_FLX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_rnd_ne.vo -flocq/Core/Fcore_FTZ.vo flocq/Core/Fcore_FTZ.glob flocq/Core/Fcore_FTZ.v.beautified: flocq/Core/Fcore_FTZ.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo +flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FIX.glob flocq/Core/Fcore_FIX.v.beautified: flocq/Core/Fcore_FIX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo +flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_FLT.glob flocq/Core/Fcore_FLT.v.beautified: flocq/Core/Fcore_FLT.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo +flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLX.glob flocq/Core/Fcore_FLX.v.beautified: flocq/Core/Fcore_FLX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo +flocq/Core/Fcore_FTZ.vo flocq/Core/Fcore_FTZ.glob flocq/Core/Fcore_FTZ.v.beautified: flocq/Core/Fcore_FTZ.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_generic_fmt.glob flocq/Core/Fcore_generic_fmt.v.beautified: flocq/Core/Fcore_generic_fmt.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_rnd.glob flocq/Core/Fcore_rnd.v.beautified: flocq/Core/Fcore_rnd.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd_ne.vo flocq/Core/Fcore_rnd_ne.glob flocq/Core/Fcore_rnd_ne.v.beautified: flocq/Core/Fcore_rnd_ne.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_ulp.vo diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml index 75724d43..bb0c0c04 100644 --- a/arm/AsmToJSON.ml +++ b/arm/AsmToJSON.ml @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(* Simple functions to serialize powerpc Asm to JSON *) +(* Simple functions to serialize arm Asm to JSON *) (* Dummy function *) diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index d13015ff..990f207d 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -395,17 +395,38 @@ let expand_instruction instr = | _ -> emit instr -let expand_function fn = +let int_reg_to_dwarf = function + | IR0 -> 0 | IR1 -> 1 | IR2 -> 2 | IR3 -> 3 + | IR4 -> 4 | IR5 -> 5 | IR6 -> 6 | IR7 -> 7 + | IR8 -> 8 | IR9 -> 9 | IR10 -> 10 | IR11 -> 11 + | IR12 -> 12 | IR13 -> 13 | IR14 -> 14 + +let float_reg_to_dwarf = function + | FR0 -> 64 | FR1 -> 65 | FR2 -> 66 | FR3 -> 67 + | FR4 -> 68 | FR5 -> 69 | FR6 -> 70 | FR7 -> 71 + | FR8 -> 72 | FR9 -> 73 | FR10 -> 74 | FR11 -> 75 + | FR12 -> 76 | FR13 -> 77 | FR14 -> 78 | FR15 -> 79 + +let preg_to_dwarf = function + | IR r -> int_reg_to_dwarf r + | FR r -> float_reg_to_dwarf r + | _ -> assert false + + +let expand_function id fn = try set_current_function fn; - List.iter expand_instruction fn.fn_code; + if !Clflags.option_g then + expand_debug id 13 preg_to_dwarf expand_instruction fn.fn_code + else + List.iter expand_instruction fn.fn_code; Errors.OK (get_current_function ()) with Error s -> Errors.Error (Errors.msg (coqstring_of_camlstring s)) -let expand_fundef = function +let expand_fundef id = function | Internal f -> - begin match expand_function f with + begin match expand_function id f with | Errors.OK tf -> Errors.OK (Internal tf) | Errors.Error msg -> Errors.Error msg end @@ -413,4 +434,4 @@ let expand_fundef = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program expand_fundef p + AST.transform_partial_ident_program expand_fundef p diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index f7f0d313..2e676090 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -20,6 +20,7 @@ open AST open Memdata open Asm open PrintAsmaux +open Fileinfo (* Type for the ABI versions *) type float_abi_type = @@ -152,8 +153,11 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = | Section_user(s, wr, ex) -> sprintf ".section \"%s\",\"a%s%s\",%%progbits" s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info - | Section_debug_abbrev -> "" (* Dummy value *) + | Section_debug_info _ -> ".section .debug_info,\"\",%progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" + let section oc sec = fprintf oc " %s\n" (name_of_section sec) @@ -894,25 +898,31 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = | _ -> "armv7"); fprintf oc " .fpu %s\n" (if Opt.vfpv3 then "vfpv3-d16" else "vfpv2"); - fprintf oc " .%s\n" (if !Clflags.option_mthumb then "thumb" else "arm") - - let print_epilogue oc = () - - let default_falignment = 4 + fprintf oc " .%s\n" (if !Clflags.option_mthumb then "thumb" else "arm"); + if !Clflags.option_g then begin + section oc Section_text; + let low_pc = new_label () in + Debug.add_compilation_section_start ".text" low_pc; + fprintf oc "%a:\n" elf_label low_pc; + fprintf oc " .cfi_sections .debug_frame\n" + end - let get_start_addr () = -1 (* Dummy constant *) - let get_end_addr () = -1 (* Dummy constant *) + let print_epilogue oc = + if !Clflags.option_g then begin + let high_pc = new_label () in + Debug.add_compilation_section_end ".text" high_pc; + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + fprintf oc "%a:\n" elf_label high_pc + end - let get_stmt_list_addr () = -1 (* Dummy constant *) - module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *) - + let default_falignment = 4 + let label = elf_label let new_label = new_label - - let print_file_loc _ _ = () (* Dummy function *) end let sel_target () = diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index 6ce6c005..25be9be3 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -55,3 +55,93 @@ 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 translate_annot sp preg_to_dwarf annot = + let rec aux = function + | BA x -> Some (sp,BA (preg_to_dwarf x)) + | BA_int _ + | BA_long _ + | BA_float _ + | BA_single _ + | BA_loadglobal _ + | BA_addrglobal _ + | BA_loadstack _ -> None + | BA_addrstack ofs -> Some (sp,BA_addrstack ofs) + | BA_splitlong (hi,lo) -> + begin + match (aux hi,aux lo) with + | Some (_,hi) ,Some (_,lo) -> Some (sp,BA_splitlong (hi,lo)) + | _,_ -> None + end in + (match annot with + | [] -> None + | a::_ -> aux a) + + +let expand_debug id sp preg 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 translate_annot sp preg 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 translate_annot sp preg 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/backend/Constprop.v b/backend/Constprop.v index cd844d30..8f4cb76d 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -144,9 +144,9 @@ Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) := | a :: al => let a' := builtin_arg_reduction ae a in let al' := a :: debug_strength_reduction ae al in - match a' with - | BA_int _ | BA_long _ | BA_float _ | BA_single _ => a' :: al' - | _ => al' + match a, a' with + | BA _, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => a' :: al' + | _, _ => al' end end. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index d9005f5e..eafefed5 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -243,7 +243,11 @@ Proof. induction 2; simpl. - exists (@nil val); constructor. - destruct IHlist_forall2 as (vl' & A). - destruct (builtin_arg_reduction ae a1); repeat (eauto; econstructor). + assert (eval_builtin_args ge (fun r => rs#r) sp m + (a1 :: debug_strength_reduction ae al) (b1 :: vl')) + by (constructor; eauto). + destruct a1; try (econstructor; eassumption). + destruct (builtin_arg_reduction ae (BA x)); repeat (eauto; econstructor). Qed. Lemma builtin_strength_reduction_correct: diff --git a/backend/Fileinfo.ml b/backend/Fileinfo.ml new file mode 100644 index 00000000..0490def0 --- /dev/null +++ b/backend/Fileinfo.ml @@ -0,0 +1,80 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Printf + +(* Printing annotations in asm syntax *) + +let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t + = Hashtbl.create 7 + +let last_file = ref "" + +let reset_filenames () = + Hashtbl.clear filename_info; last_file := "" + +let close_filenames () = + Hashtbl.iter + (fun file (num, fb) -> + match fb with Some b -> Printlines.close b | None -> ()) + filename_info; + reset_filenames() + +let enter_filename f = + let num = Hashtbl.length filename_info + 1 in + let filebuf = + if !Clflags.option_S || !Clflags.option_dasm then begin + try Some (Printlines.openfile f) + with Sys_error _ -> None + end else None in + Hashtbl.add filename_info f (num, filebuf); + (num, filebuf) + +(* Add file and line debug location, using GNU assembler-style DWARF2 + directives *) +let print_file oc file = + try + Hashtbl.find filename_info file + with Not_found -> + let (filenum, filebuf as res) = enter_filename file in + fprintf oc " .file %d %S\n" filenum file; + res + +let print_file_line oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (filenum, filebuf) = print_file oc file in + fprintf oc " .loc %d %d\n" filenum line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end + +(* Add file and line debug location, using DWARF2 directives in the style + of Diab C 5 *) + +let print_file_line_d2 oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (_, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + enter_filename file in + if file <> !last_file then begin + fprintf oc " .d2file %S\n" file; + last_file := file + end; + fprintf oc " .d2line %d\n" line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index f3c80f3e..594b43b7 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -24,14 +24,11 @@ open TargetPrinter module Printer(Target:TARGET) = struct - let addr_mapping: (string, (int * int)) Hashtbl.t = Hashtbl.create 7 - let get_fun_addr name = - let name = extern_atom name in - let start_addr = new_label () - and end_addr = new_label () in - Hashtbl.add addr_mapping name (start_addr,end_addr); - start_addr,end_addr + let s = Target.new_label () + and e = Target.new_label () in + Debug.add_fun_addr name (e,s); + s,e let print_debug_label oc l = if !Clflags.option_g && Configuration.advanced_debug then @@ -39,7 +36,6 @@ module Printer(Target:TARGET) = else () - let print_location oc loc = if loc <> Cutil.no_loc then Target.print_file_line oc (fst loc) (snd loc) @@ -67,7 +63,9 @@ module Printer(Target:TARGET) = print_debug_label oc e; Target.print_fun_info oc name; Target.emit_constants oc lit; - Target.print_jumptable oc jmptbl + Target.print_jumptable oc jmptbl; + if !Clflags.option_g then + Hashtbl.iter (fun p i -> Debug.add_label name p i) current_function_labels let print_init_data oc name id = if Str.string_match PrintCsyntax.re_string_literal (extern_atom name) 0 @@ -81,10 +79,11 @@ module Printer(Target:TARGET) = match v.gvar_init with | [] -> () | _ -> + Debug.variable_printed (extern_atom name); let sec = match C2C.atom_sections name with | [s] -> s - | _ -> Section_data true + | _ -> Section_data true and align = match C2C.atom_alignof name with | Some a -> a @@ -102,8 +101,7 @@ module Printer(Target:TARGET) = let sz = match v.gvar_init with [Init_space sz] -> sz | _ -> assert false in Target.print_comm_symb oc sz name align - - + let print_globdef oc (name,gdef) = match gdef with | Gfun (Internal code) -> print_function oc name code @@ -113,33 +111,34 @@ module Printer(Target:TARGET) = module DwarfTarget: DwarfTypes.DWARF_TARGET = struct let label = Target.label + let section = Target.section let name_of_section = Target.name_of_section - let print_file_loc = Target.print_file_loc - let get_start_addr = Target.get_start_addr - let get_end_addr = Target.get_end_addr - let get_stmt_list_addr = Target.get_stmt_list_addr - let name_of_section = Target.name_of_section - let get_fun_addr s = try Some (Hashtbl.find addr_mapping s) with Not_found -> None + let symbol = Target.symbol end - module DebugPrinter = DwarfPrinter (DwarfTarget) (Target.DwarfAbbrevs) - - + module DebugPrinter = DwarfPrinter (DwarfTarget) end let print_program oc p db = let module Target = (val (sel_target ()):TARGET) in let module Printer = Printer(Target) in - reset_filenames (); + Fileinfo.reset_filenames (); print_version_and_options oc Target.comment; Target.print_prologue oc; List.iter (Printer.print_globdef oc) p.prog_defs; Target.print_epilogue oc; - close_filenames (); if !Clflags.option_g && Configuration.advanced_debug then begin - match db with + let atom_to_s s = + let s = C2C.atom_sections s in + match s with + | [] -> Target.name_of_section Section_text + | (Section_user (n,_,_))::_ -> n + | a::_ -> + Target.name_of_section a in + match Debug.generate_debug_info atom_to_s (Target.name_of_section Section_text) with | None -> () | Some db -> Printer.DebugPrinter.print_debug oc db - end + end; + Fileinfo.close_filenames () diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 67e53aea..78399c04 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -14,7 +14,6 @@ open AST open Asm open Camlcoq -open DwarfTypes open Datatypes open Memdata open Printf @@ -45,13 +44,8 @@ module type TARGET = val comment: string val symbol: out_channel -> P.t -> unit val default_falignment: int - val get_start_addr: unit -> int - val get_end_addr: unit -> int - val get_stmt_list_addr: unit -> int val new_label: unit -> int val label: out_channel -> int -> unit - val print_file_loc: out_channel -> file_loc -> unit - module DwarfAbbrevs: DWARF_ABBREVS end (* On-the-fly label renaming *) @@ -139,77 +133,6 @@ let cfi_rel_offset = let coqint oc n = fprintf oc "%ld" (camlint_of_coqint n) -(* Printing annotations in asm syntax *) -(** All files used in the debug entries *) -module StringSet = Set.Make(String) -let all_files : StringSet.t ref = ref StringSet.empty -let add_file file = - all_files := StringSet.add file !all_files - - -let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t - = Hashtbl.create 7 - -let last_file = ref "" - -let reset_filenames () = - Hashtbl.clear filename_info; last_file := "" - -let close_filenames () = - Hashtbl.iter - (fun file (num, fb) -> - match fb with Some b -> Printlines.close b | None -> ()) - filename_info; - reset_filenames() - -let enter_filename f = - let num = Hashtbl.length filename_info + 1 in - let filebuf = - if !Clflags.option_S || !Clflags.option_dasm then begin - try Some (Printlines.openfile f) - with Sys_error _ -> None - end else None in - Hashtbl.add filename_info f (num, filebuf); - (num, filebuf) - -(* Add file and line debug location, using GNU assembler-style DWARF2 - directives *) - -let print_file_line oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (filenum, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - let (filenum, filebuf as res) = enter_filename file in - fprintf oc " .file %d %S\n" filenum file; - res in - fprintf oc " .loc %d %d\n" filenum line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end - -(* Add file and line debug location, using DWARF2 directives in the style - of Diab C 5 *) - -let print_file_line_d2 oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (_, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - enter_filename file in - if file <> !last_file then begin - fprintf oc " .d2file %S\n" file; - last_file := file - end; - fprintf oc " .d2line %d\n" line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end - (** Programmer-supplied annotations (__builtin_annot). *) let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*" @@ -283,6 +206,9 @@ let print_debug_info comment print_line print_preg sp_name oc kind txt args = | 5 -> (* local variable preallocated in stack *) fprintf oc "%s debug: %s resides at%a\n" comment txt print_debug_args args + | 6 -> (* scope annotations *) + fprintf oc "%s debug: current scopes%a\n" + comment print_debug_args args; | _ -> () @@ -330,7 +256,12 @@ let print_inline_asm print_preg oc txt sg args res = (** Print CompCert version and command-line as asm comment *) let print_version_and_options oc comment = - fprintf oc "%s File generated by CompCert %s\n" comment Version.version; + let version_string = + if Version.buildnr <> "" && Version.tag <> "" then + sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + else + Version.version in + fprintf oc "%s File generated by CompCert %s\n" comment version_string; fprintf oc "%s Command line:" comment; for i = 1 to Array.length Sys.argv - 1 do fprintf oc " %s" Sys.argv.(i) diff --git a/backend/RTL.v b/backend/RTL.v index 56a5efeb..3cd4335d 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -104,8 +104,7 @@ Record function: Type := mkfunction { for its stack-allocated activation record. [fn_params] is the list of registers that are bound to the values of arguments at call time. [fn_entrypoint] is the node of the first instruction of the function - in the CFG. [fn_code_wf] asserts that all instructions of the function - have nodes no greater than [fn_nextpc]. *) + in the CFG. *) Definition fundef := AST.fundef function. diff --git a/backend/RTLgen.v b/backend/RTLgen.v index d818de58..3da961c6 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -415,11 +415,12 @@ Fixpoint convert_builtin_args {A: Type} (al: list (builtin_arg expr)) (rl: list a1' :: convert_builtin_args al rl1 end. -Definition convert_builtin_res (map: mapping) (r: builtin_res ident) : mon (builtin_res reg) := - match r with - | BR id => do r <- find_var map id; ret (BR r) - | BR_none => ret BR_none - | _ => error (Errors.msg "RTLgen: bad builtin_res") +Definition convert_builtin_res (map: mapping) (oty: option typ) (r: builtin_res ident) : mon (builtin_res reg) := + match r, oty with + | BR id, _ => do r <- find_var map id; ret (BR r) + | BR_none, None => ret BR_none + | BR_none, Some _ => do r <- new_reg; ret (BR r) + | _, _ => error (Errors.msg "RTLgen: bad builtin_res") end. (** Translation of an expression. [transl_expr map a rd nd] @@ -598,7 +599,7 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node) let al := exprlist_of_expr_list (params_of_builtin_args args) in do rargs <- alloc_regs map al; let args' := convert_builtin_args args rargs in - do res' <- convert_builtin_res map res; + do res' <- convert_builtin_res map (sig_res (ef_sig ef)) res; do n1 <- add_instr (Ibuiltin ef args' res' nd); transl_exprlist map al rargs n1 | Sseq s1 s2 => diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 559ab3a2..19f6f1f4 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -234,6 +234,7 @@ Proof. intros. inv H1; simpl. - eapply match_env_update_var; eauto. - auto. +- eapply match_env_update_temp; eauto. Qed. (** Matching and [let]-bound variables. *) diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 41b5016f..1e665002 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -814,7 +814,10 @@ Inductive tr_builtin_res: mapping -> builtin_res ident -> builtin_res reg -> Pro map.(map_vars)!id = Some r -> tr_builtin_res map (BR id) (BR r) | tr_builtin_res_none: forall map, - tr_builtin_res map BR_none BR_none. + tr_builtin_res map BR_none BR_none + | tr_builtin_res_fresh: forall map r, + ~reg_in_map map r -> + tr_builtin_res map BR_none (BR r). (** [tr_stmt c map stmt ns ncont nexits nret rret] holds if the graph [c], starting at node [ns], contains instructions that perform the Cminor @@ -1214,14 +1217,17 @@ Proof. Qed. Lemma convert_builtin_res_charact: - forall map res s res' s' INCR - (TR: convert_builtin_res map res s = OK res' s' INCR) + forall map oty res s res' s' INCR + (TR: convert_builtin_res map oty res s = OK res' s' INCR) (WF: map_valid map s), tr_builtin_res map res res'. Proof. - destruct res; simpl; intros; monadInv TR. -- constructor. unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto. -- constructor. + destruct res; simpl; intros. +- monadInv TR. constructor. unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto. +- destruct oty; monadInv TR. ++ constructor. eauto with rtlg. ++ constructor. +- monadInv TR. Qed. Lemma transl_stmt_charact: diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 5cd5997d..bd281374 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -524,6 +524,13 @@ let convertField env f = (intern_string f.fld_name, convertTyp env f.fld_typ) let convertCompositedef env su id attr members = + let t = match su with + | C.Struct -> + let layout = Cutil.struct_layout env members in + List.iter (fun (a,b) -> Debug.set_member_offset id a b) layout; + TStruct (id,attr) + | C.Union -> TUnion (id,attr) in + Debug.set_composite_size id su (Cutil.sizeof env t); Composite(intern_string id.name, begin match su with C.Struct -> Struct | C.Union -> Union end, List.map (convertField env) members, @@ -741,6 +748,22 @@ let rec convertExpr env e = | C.ECompound(ty1, ie) -> unsupported "compound literals"; ezero + | C.ECall({edesc = C.EVar {name = "__builtin_debug"}}, args) -> + let (kind, args1) = + match args with + | {edesc = C.EConst(CInt(n,_,_))} :: args1 -> (n, args1) + | _ -> error "ill_formed __builtin_debug"; (0L, args) in + let (text, args2) = + match args1 with + | {edesc = C.EConst(CStr(txt))} :: args2 -> (txt, args2) + | {edesc = C.EVar id} :: args2 -> (id.name, args2) + | _ -> error "ill_formed __builtin_debug"; ("", args1) in + let targs2 = convertTypArgs env [] args2 in + Ebuiltin( + EF_debug(P.of_int64 kind, intern_string text, + typlist_of_typelist targs2), + targs2, convertExprList env args2, convertTyp env e.etyp) + | C.ECall({edesc = C.EVar {name = "__builtin_annot"}}, args) -> begin match args with | {edesc = C.EConst(CStr txt)} :: args1 -> @@ -922,16 +945,6 @@ let rec contains_case s = (** Annotations for line numbers *) -let add_lineno prev_loc this_loc s = - if !Clflags.option_g && prev_loc <> this_loc && this_loc <> Cutil.no_loc - then begin - let txt = sprintf "#line:%s:%d" (fst this_loc) (snd this_loc) in - Ssequence(Sdo(Ebuiltin(EF_debug(P.one, intern_string txt, []), - Tnil, Enil, Tvoid)), - s) - end else - s - (** Statements *) let swrap = function @@ -939,36 +952,31 @@ let swrap = function | Errors.Error msg -> error ("retyping error: " ^ string_of_errmsg msg); Sskip -let rec convertStmt ploc env s = +let rec convertStmt env s = updateLoc s.sloc; match s.sdesc with | C.Sskip -> Sskip | C.Sdo e -> - add_lineno ploc s.sloc (swrap (Ctyping.sdo (convertExpr env e))) + swrap (Ctyping.sdo (convertExpr env e)) | C.Sseq(s1, s2) -> - let s1' = convertStmt ploc env s1 in - let s2' = convertStmt s1.sloc env s2 in + let s1' = convertStmt env s1 in + let s2' = convertStmt env s2 in Ssequence(s1', s2') | C.Sif(e, s1, s2) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sifthenelse te - (convertStmt s.sloc env s1) (convertStmt s.sloc env s2))) + swrap (Ctyping.sifthenelse te (convertStmt env s1) (convertStmt env s2)) | C.Swhile(e, s1) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.swhile te (convertStmt s.sloc env s1))) + swrap (Ctyping.swhile te (convertStmt env s1)) | C.Sdowhile(s1, e) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sdowhile te (convertStmt s.sloc env s1))) + swrap (Ctyping.sdowhile te (convertStmt env s1)) | C.Sfor(s1, e, s2, s3) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sfor - (convertStmt s.sloc env s1) te - (convertStmt s.sloc env s2) (convertStmt s.sloc env s3))) + swrap (Ctyping.sfor + (convertStmt env s1) te + (convertStmt env s2) (convertStmt env s3)) | C.Sbreak -> Sbreak | C.Scontinue -> @@ -981,22 +989,20 @@ let rec convertStmt ploc env s = contains_case init end; let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sswitch te - (convertSwitch s.sloc env (is_longlong env e.etyp) cases))) + swrap (Ctyping.sswitch te + (convertSwitch env (is_longlong env e.etyp) cases)) | C.Slabeled(C.Slabel lbl, s1) -> - add_lineno ploc s.sloc - (Slabel(intern_string lbl, convertStmt s.sloc env s1)) + Slabel(intern_string lbl, convertStmt env s1) | C.Slabeled(C.Scase _, _) -> unsupported "'case' outside of 'switch'"; Sskip | C.Slabeled(C.Sdefault, _) -> unsupported "'default' outside of 'switch'"; Sskip | C.Sgoto lbl -> - add_lineno ploc s.sloc (Sgoto(intern_string lbl)) + Sgoto(intern_string lbl) | C.Sreturn None -> - add_lineno ploc s.sloc (Sreturn None) + Sreturn None | C.Sreturn(Some e) -> - add_lineno ploc s.sloc (Sreturn(Some(convertExpr env e))) + Sreturn(Some(convertExpr env e)) | C.Sblock _ -> unsupported "nested blocks"; Sskip | C.Sdecl _ -> @@ -1004,10 +1010,9 @@ let rec convertStmt ploc env s = | C.Sasm(attrs, txt, outputs, inputs, clobber) -> if not !Clflags.option_finline_asm then unsupported "inline 'asm' statement (consider adding option -finline-asm)"; - add_lineno ploc s.sloc - (Sdo (convertAsm s.sloc env txt outputs inputs clobber)) + Sdo (convertAsm s.sloc env txt outputs inputs clobber) -and convertSwitch ploc env is_64 = function +and convertSwitch env is_64 = function | [] -> LSnil | (lbl, s) :: rem -> @@ -1024,7 +1029,7 @@ and convertSwitch ploc env is_64 = function then Z.of_uint64 v else Z.of_uint32 (Int64.to_int32 v)) in - LScons(lbl', convertStmt ploc env s, convertSwitch s.sloc env is_64 rem) + LScons(lbl', convertStmt env s, convertSwitch env is_64 rem) (** Function definitions *) @@ -1038,7 +1043,9 @@ let convertFundef loc env fd = let params = List.map (fun (id, ty) -> - (intern_string id.name, convertTyp env ty)) + let id' = intern_string id.name in + Debug.atom_parameter fd.fd_name id id'; + (id', convertTyp env ty)) fd.fd_params in let vars = List.map @@ -1047,10 +1054,13 @@ let convertFundef loc env fd = unsupported "'static' or 'extern' local variable"; if init <> None then unsupported "initialized local variable"; - (intern_string id.name, convertTyp env ty)) + let id' = intern_string id.name in + Debug.atom_local_variable id id'; + (id', convertTyp env ty)) fd.fd_locals in - let body' = convertStmt loc env fd.fd_body in + let body' = convertStmt env fd.fd_body in let id' = intern_string fd.fd_name.name in + Debug.atom_function fd.fd_name id'; Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; a_alignment = None; @@ -1116,6 +1126,7 @@ let convertInitializer env ty i = let convertGlobvar loc env (sto, id, ty, optinit) = let id' = intern_string id.name in + Debug.atom_global_variable id id'; let ty' = convertTyp env ty in let sz = Ctypes.sizeof !comp_env ty' in let al = Ctypes.alignof !comp_env ty' in diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index a555f792..1f55da7f 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -802,13 +802,13 @@ Program Definition composite_of_def Next Obligation. apply Zle_ge. eapply Zle_trans. eapply sizeof_composite_pos. apply align_le; apply alignof_composite_pos. -Qed. +Defined. Next Obligation. apply align_attr_two_p. apply alignof_composite_two_p. -Qed. +Defined. Next Obligation. apply align_divides. apply alignof_composite_pos. -Qed. +Defined. (** The composite environment for a program is obtained by entering its composite definitions in sequence. The definitions are assumed diff --git a/common/AST.v b/common/AST.v index 4d929f13..4e02b3d4 100644 --- a/common/AST.v +++ b/common/AST.v @@ -264,10 +264,46 @@ Qed. End TRANSF_PROGRAM. +(** General iterator over program that applies a given code transfomration + function to all function descriptions with their identifers and leaves + teh other parts of the program unchanged. *) + +Section TRANSF_PROGRAM_IDENT. + +Variable A B V: Type. +Variable transf: ident -> A -> B. + +Definition transform_program_globdef_ident (idg: ident * globdef A V) : ident * globdef B V := + match idg with + | (id, Gfun f) => (id, Gfun (transf id f)) + | (id, Gvar v) => (id, Gvar v) + end. + +Definition transform_program_ident (p: program A V): program B V := + mkprogram + (List.map transform_program_globdef_ident p.(prog_defs)) + p.(prog_public) + p.(prog_main). + +Lemma tranforma_program_function_ident: + forall p i tf, + In (i, Gfun tf) (transform_program_ident p).(prog_defs) -> + exists f, In (i, Gfun f) p.(prog_defs) /\ transf i f = tf. +Proof. + simpl. unfold transform_program_ident. intros. + exploit list_in_map_inv; eauto. + intros [[i' gd] [EQ IN]]. simpl in EQ. destruct gd; inv EQ. + exists f; auto. +Qed. + +End TRANSF_PROGRAM_IDENT. + (** The following is a more general presentation of [transform_program] where global variable information can be transformed, in addition to function definitions. Moreover, the transformation functions can fail and - return an error message. *) + return an error message. Also the transformation functions are defined + for the case the identifier of the function is passed as additional + argument *) Open Local Scope error_monad_scope. Open Local Scope string_scope. @@ -276,12 +312,18 @@ Section TRANSF_PROGRAM_GEN. Variables A B V W: Type. Variable transf_fun: A -> res B. +Variable transf_fun_ident: ident -> A -> res B. Variable transf_var: V -> res W. +Variable transf_var_ident: ident -> V -> res W. Definition transf_globvar (g: globvar V) : res (globvar W) := do info' <- transf_var g.(gvar_info); OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)). +Definition transf_globvar_ident (i: ident) (g: globvar V) : res (globvar W) := + do info' <- transf_var_ident i g.(gvar_info); + OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)). + Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) := match l with | nil => OK nil @@ -299,10 +341,31 @@ Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * gl end end. +Fixpoint transf_globdefs_ident (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) := + match l with + | nil => OK nil + | (id, Gfun f) :: l' => + match transf_fun_ident id f with + | Error msg => Error (MSG "In function " :: CTX id :: MSG ": " :: msg) + | OK tf => + do tl' <- transf_globdefs_ident l'; OK ((id, Gfun tf) :: tl') + end + | (id, Gvar v) :: l' => + match transf_globvar_ident id v with + | Error msg => Error (MSG "In variable " :: CTX id :: MSG ": " :: msg) + | OK tv => + do tl' <- transf_globdefs_ident l'; OK ((id, Gvar tv) :: tl') + end + end. + Definition transform_partial_program2 (p: program A V) : res (program B W) := do gl' <- transf_globdefs p.(prog_defs); OK (mkprogram gl' p.(prog_public) p.(prog_main)). +Definition transform_partial_ident_program2 (p: program A V) : res (program B W) := + do gl' <- transf_globdefs_ident p.(prog_defs); + OK (mkprogram gl' p.(prog_public) p.(prog_main)). + Lemma transform_partial_program2_function: forall p tp i tf, transform_partial_program2 p = OK tp -> @@ -321,6 +384,24 @@ Proof. exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. Qed. +Lemma transform_partial_ident_program2_function: + forall p tp i tf, + transform_partial_ident_program2 p = OK tp -> + In (i, Gfun tf) tp.(prog_defs) -> + exists f, In (i, Gfun f) p.(prog_defs) /\ transf_fun_ident i f = OK tf. +Proof. + intros. monadInv H. simpl in H0. + revert x EQ H0. induction (prog_defs p); simpl; intros. + inv EQ. contradiction. + destruct a as [id [f|v]]. + destruct (transf_fun_ident id f) as [tf1|msg] eqn:?; monadInv EQ. + simpl in H0; destruct H0. inv H. exists f; auto. + exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. + destruct (transf_globvar_ident id v) as [tv1|msg] eqn:?; monadInv EQ. + simpl in H0; destruct H0. inv H. + exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. +Qed. + Lemma transform_partial_program2_variable: forall p tp i tv, transform_partial_program2 p = OK tp -> @@ -342,6 +423,28 @@ Proof. exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. Qed. + +Lemma transform_partial_ident_program2_variable: + forall p tp i tv, + transform_partial_ident_program2 p = OK tp -> + In (i, Gvar tv) tp.(prog_defs) -> + exists v, + In (i, Gvar(mkglobvar v tv.(gvar_init) tv.(gvar_readonly) tv.(gvar_volatile))) p.(prog_defs) + /\ transf_var_ident i v = OK tv.(gvar_info). +Proof. + intros. monadInv H. simpl in H0. + revert x EQ H0. induction (prog_defs p); simpl; intros. + inv EQ. contradiction. + destruct a as [id [f|v]]. + destruct (transf_fun_ident id f) as [tf1|msg] eqn:?; monadInv EQ. + simpl in H0; destruct H0. inv H. + exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. + destruct (transf_globvar_ident id v) as [tv1|msg] eqn:?; monadInv EQ. + simpl in H0; destruct H0. inv H. + monadInv Heqr. simpl. exists (gvar_info v). split. left. destruct v; auto. auto. + exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. +Qed. + Lemma transform_partial_program2_succeeds: forall p tp i g, transform_partial_program2 p = OK tp -> @@ -361,6 +464,25 @@ Proof. destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto. Qed. +Lemma transform_partial_ident_program2_succeeds: + forall p tp i g, + transform_partial_ident_program2 p = OK tp -> + In (i, g) p.(prog_defs) -> + match g with + | Gfun fd => exists tfd, transf_fun_ident i fd = OK tfd + | Gvar gv => exists tv, transf_var_ident i gv.(gvar_info) = OK tv + end. +Proof. + intros. monadInv H. + revert x EQ H0. induction (prog_defs p); simpl; intros. + contradiction. + destruct a as [id1 g1]. destruct g1. + destruct (transf_fun_ident id1 f) eqn:TF; try discriminate. monadInv EQ. + destruct H0. inv H. econstructor; eauto. eapply IHl; eauto. + destruct (transf_globvar_ident id1 v) eqn:TV; try discriminate. monadInv EQ. + destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto. +Qed. + Lemma transform_partial_program2_main: forall p tp, transform_partial_program2 p = OK tp -> @@ -369,6 +491,14 @@ Proof. intros. monadInv H. reflexivity. Qed. +Lemma transform_partial_ident_program2_main: + forall p tp, + transform_partial_ident_program2 p = OK tp -> + tp.(prog_main) = p.(prog_main). +Proof. + intros. monadInv H. reflexivity. +Qed. + Lemma transform_partial_program2_public: forall p tp, transform_partial_program2 p = OK tp -> @@ -377,6 +507,14 @@ Proof. intros. monadInv H. reflexivity. Qed. +Lemma transform_partial_ident_program2_public: + forall p tp, + transform_partial_ident_program2 p = OK tp -> + tp.(prog_public) = p.(prog_public). +Proof. + intros. monadInv H. reflexivity. +Qed. + (** Additionally, we can also "augment" the program with new global definitions and a different "main" function. *) @@ -397,6 +535,18 @@ Proof. intros. monadInv H. reflexivity. Qed. +Definition transform_partial_augment_ident_program (p: program A V) : res (program B W) := + do gl' <- transf_globdefs_ident p.(prog_defs); + OK(mkprogram (gl' ++ new_globs) p.(prog_public) new_main). + +Lemma transform_partial_augment_ident_program_main: + forall p tp, + transform_partial_augment_ident_program p = OK tp -> + tp.(prog_main) = new_main. +Proof. + intros. monadInv H. reflexivity. +Qed. + End AUGMENT. Remark transform_partial_program2_augment: @@ -409,6 +559,16 @@ Proof. simpl. f_equal. f_equal. rewrite <- app_nil_end. auto. Qed. +Remark transform_partial_ident_program2_augment: + forall p, + transform_partial_ident_program2 p = + transform_partial_augment_ident_program nil p.(prog_main) p. +Proof. + unfold transform_partial_ident_program2, transform_partial_augment_ident_program; intros. + destruct (transf_globdefs_ident (prog_defs p)); auto. + simpl. f_equal. f_equal. rewrite <- app_nil_end. auto. +Qed. + End TRANSF_PROGRAM_GEN. (** The following is a special case of [transform_partial_program2], @@ -418,10 +578,14 @@ Section TRANSF_PARTIAL_PROGRAM. Variable A B V: Type. Variable transf_partial: A -> res B. +Variable transf_partial_ident: ident -> A -> res B. Definition transform_partial_program (p: program A V) : res (program B V) := transform_partial_program2 transf_partial (fun v => OK v) p. +Definition transform_partial_ident_program (p: program A V) : res (program B V) := + transform_partial_ident_program2 transf_partial_ident (fun _ v => OK v) p. + Lemma transform_partial_program_main: forall p tp, transform_partial_program p = OK tp -> @@ -430,6 +594,14 @@ Proof. apply transform_partial_program2_main. Qed. +Lemma transform_partial_ident_program_main: + forall p tp, + transform_partial_ident_program p = OK tp -> + tp.(prog_main) = p.(prog_main). +Proof. + apply transform_partial_ident_program2_main. +Qed. + Lemma transform_partial_program_public: forall p tp, transform_partial_program p = OK tp -> @@ -438,6 +610,14 @@ Proof. apply transform_partial_program2_public. Qed. +Lemma transform_partial_ident_program_public: + forall p tp, + transform_partial_ident_program p = OK tp -> + tp.(prog_public) = p.(prog_public). +Proof. + apply transform_partial_ident_program2_public. +Qed. + Lemma transform_partial_program_function: forall p tp i tf, transform_partial_program p = OK tp -> @@ -447,6 +627,15 @@ Proof. apply transform_partial_program2_function. Qed. +Lemma transform_partial_ident_program_function: + forall p tp i tf, + transform_partial_ident_program p = OK tp -> + In (i, Gfun tf) tp.(prog_defs) -> + exists f, In (i, Gfun f) p.(prog_defs) /\ transf_partial_ident i f = OK tf. +Proof. + apply transform_partial_ident_program2_function. +Qed. + Lemma transform_partial_program_succeeds: forall p tp i fd, transform_partial_program p = OK tp -> @@ -457,6 +646,16 @@ Proof. exploit transform_partial_program2_succeeds; eauto. Qed. +Lemma transform_partial_ident_program_succeeds: + forall p tp i fd, + transform_partial_ident_program p = OK tp -> + In (i, Gfun fd) p.(prog_defs) -> + exists tfd, transf_partial_ident i fd = OK tfd. +Proof. + unfold transform_partial_ident_program; intros. + exploit transform_partial_ident_program2_succeeds; eauto. +Qed. + End TRANSF_PARTIAL_PROGRAM. Lemma transform_program_partial_program: @@ -475,6 +674,22 @@ Proof. destruct v; auto. Qed. +Lemma transform_program_partial_ident_program: + forall (A B V: Type) (transf: ident -> A -> B) (p: program A V), + transform_partial_ident_program (fun id f => OK(transf id f)) p = OK(transform_program_ident transf p). +Proof. + intros. + unfold transform_partial_ident_program, transform_partial_ident_program2, transform_program; intros. + replace (transf_globdefs_ident (fun id f => OK (transf id f)) (fun _ v => OK v) p.(prog_defs)) + with (OK (map (transform_program_globdef_ident transf) p.(prog_defs))). + auto. + induction (prog_defs p); simpl. + auto. + destruct a as [id [f|v]]; rewrite <- IHl. + auto. + destruct v; auto. +Qed. + (** The following is a relational presentation of [transform_partial_augment_preogram]. Given relations between function definitions and between variable information, it defines a relation diff --git a/common/Sections.ml b/common/Sections.ml index c0c95848..cc8b0758 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -27,8 +27,10 @@ type section_name = | Section_literal | Section_jumptable | Section_user of string * bool (*writable*) * bool (*executable*) - | Section_debug_info + | Section_debug_info of string | Section_debug_abbrev + | Section_debug_loc + | Section_debug_line of string type access_mode = | Access_default diff --git a/common/Sections.mli b/common/Sections.mli index e878b9e5..7a8c8225 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -26,8 +26,10 @@ type section_name = | Section_literal | Section_jumptable | Section_user of string * bool (*writable*) * bool (*executable*) - | Section_debug_info + | Section_debug_info of string | Section_debug_abbrev + | Section_debug_loc + | Section_debug_line of string type access_mode = | Access_default @@ -124,7 +124,8 @@ case "$target" in casmruntime="${toolprefix}gcc -c -Wa,-mregnames" clinker="${toolprefix}gcc" libmath="-lm" - cchecklink=${build_checklink};; + cchecklink=${build_checklink} + advanced_debug=true;; esac;; arm*-*) arch="arm" diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index 6569bb4c..d064f4b1 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -111,16 +111,16 @@ let pack_bitfields env sid ml = end in pack [] 0 ml -let rec transf_members env id count = function +let rec transf_struct_members env id count = function | [] -> [] | m :: ms as ml -> if m.fld_bitfield = None then - m :: transf_members env id count ms + m :: transf_struct_members env id count ms else begin let (nbits, bitfields, ml') = pack_bitfields env id ml in if nbits = 0 then (* Lone zero-size bitfield: just ignore *) - transf_members env id count ml' + transf_struct_members env id count ml' else begin (* Create integer field of sufficient size for this bitfield group *) let carrier = sprintf "__bf%d" count in @@ -134,6 +134,7 @@ let rec transf_members env id count = function if !config.bitfields_msb_first then sizeof_ikind carrier_ikind * 8 - pos - sz else pos in + Debug.set_bitfield_offset id name pos carrier (sizeof_ikind carrier_ikind); Hashtbl.add bitfield_table (id, name) {bf_carrier = carrier; bf_carrier_typ = carrier_typ; @@ -143,14 +144,49 @@ let rec transf_members env id count = function end) bitfields; { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None} - :: transf_members env id (count + 1) ml' + :: transf_struct_members env id (count + 1) ml' end end +let rec transf_union_members env id count = function + [] -> [] + | m :: ms -> + (match m.fld_bitfield with + | None -> m::transf_union_members env id count ms + | Some nbits -> + let carrier = sprintf "__bf%d" count in + let carrier_ikind = unsigned_ikind_for_carrier nbits in + let carrier_typ = TInt(carrier_ikind, []) in + let signed = + match unroll env m.fld_typ with + | TInt(ik, _) -> is_signed_ikind ik + | TEnum(eid, _) -> is_signed_enum_bitfield env id m.fld_name eid nbits + | _ -> assert false (* should never happen, checked in Elab *) in + let signed2 = + match unroll env (type_of_member env m) with + | TInt(ik, _) -> is_signed_ikind ik + | _ -> assert false (* should never happen, checked in Elab *) in + let pos' = + if !config.bitfields_msb_first + then sizeof_ikind carrier_ikind * 8 - nbits + else 0 in + let is_bool = + match unroll env m.fld_typ with + | TInt(IBool, _) -> true + | _ -> false in + Hashtbl.add bitfield_table + (id, m.fld_name) + {bf_carrier = carrier; bf_carrier_typ = carrier_typ; + bf_pos = pos'; bf_size = nbits; + bf_signed = signed; bf_signed_res = signed2; + bf_bool = is_bool}; + { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None} + :: transf_struct_members env id (count + 1) ms) + let transf_composite env su id attr ml = match su with - | Struct -> (attr, transf_members env id 1 ml) - | Union -> (attr, ml) + | Struct -> (attr, transf_struct_members env id 1 ml) + | Union -> (attr, transf_union_members env id 1 ml) (* Bitfield manipulation expressions *) @@ -317,6 +353,7 @@ let rec is_bitfield_access env e = match e.edesc with | EUnop(Odot fieldname, e1) -> begin match unroll env e1.etyp with + | TUnion (id,_) | TStruct(id, _) -> (try Some(e1, Hashtbl.find bitfield_table (id, fieldname)) with Not_found -> None) diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml index 254f6fed..c81fd498 100644 --- a/cparser/Cleanup.ml +++ b/cparser/Cleanup.ml @@ -184,6 +184,11 @@ let saturate p = (* Remove unreferenced definitions *) +let remove_unused_debug = function + | Gdecl (_,id,_,_) -> Debug.remove_unused id + | Gfundef f -> Debug.remove_unused f.fd_name + | _ -> () + let rec simpl_globdecls accu = function | [] -> accu | g :: rem -> @@ -199,7 +204,7 @@ let rec simpl_globdecls accu = function | Gpragma s -> true in if need then simpl_globdecls (g :: accu) rem - else simpl_globdecls accu rem + else begin remove_unused_debug g.gdesc; simpl_globdecls accu rem end let program p = referenced := IdentSet.empty; diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml index 4ceaa016..1af5af1e 100644 --- a/cparser/Cprint.ml +++ b/cparser/Cprint.ml @@ -20,6 +20,8 @@ open C let print_idents_in_full = ref false +let print_debug_idents = ref false + let print_line_numbers = ref false let location pp (file, lineno) = @@ -27,7 +29,9 @@ let location pp (file, lineno) = fprintf pp "# %d \"%s\"@ " lineno file let ident pp i = - if !print_idents_in_full + if !print_debug_idents + then fprintf pp "$%d" i.stamp + else if !print_idents_in_full then fprintf pp "%s$%d" i.name i.stamp else fprintf pp "%s" i.name diff --git a/cparser/Cprint.mli b/cparser/Cprint.mli index d63e341c..349b5f9a 100644 --- a/cparser/Cprint.mli +++ b/cparser/Cprint.mli @@ -15,6 +15,7 @@ val print_idents_in_full : bool ref val print_line_numbers : bool ref +val print_debug_idents : bool ref val location : Format.formatter -> C.location -> unit val attributes : Format.formatter -> C.attributes -> unit diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index a3c05c34..0def347f 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -273,6 +273,42 @@ let combine_types mode env t1 t2 = in try Some(comp mode t1 t2) with Incompat -> None +let rec equal_types env t1 t2 = + match t1, t2 with + | TVoid a1, TVoid a2 -> + a1=a2 + | TInt(ik1, a1), TInt(ik2, a2) -> + ik1 = ik2 && a1 = a2 + | TFloat(fk1, a1), TFloat(fk2, a2) -> + fk1 = fk2 && a1 = a2 + | TPtr(ty1, a1), TPtr(ty2, a2) -> + a1 = a2 && equal_types env ty1 ty2 + | TArray(ty1, sz1, a1), TArray(ty2, sz2, a2) -> + let size = begin match sz1,sz2 with + | None, None -> true + | Some s1, Some s2 -> s1 = s2 + | _ -> false end in + size && a1 = a2 && equal_types env t1 t2 + | TFun(ty1, params1, vararg1, a1), TFun(ty2, params2, vararg2, a2) -> + let params = + match params1, params2 with + | None, None -> true + | None, Some _ + | Some _, None -> false + | Some l1, Some l2 -> + try + List.for_all2 (fun (_,t1) (_,t2) -> equal_types env t1 t2) l1 l2 + with _ -> false + in params && a1 = a2 && vararg1 = vararg2 && equal_types env ty1 ty2 + | TNamed _, _ -> equal_types env (unroll env t1) t2 + | _, TNamed _ -> equal_types env t1 (unroll env t2) + | TStruct(s1, a1), TStruct(s2, a2) + | TUnion(s1, a1), TUnion(s2, a2) + | TEnum(s1, a1), TEnum(s2, a2) -> + s1 = s2 && a1 = a2 + | _, _ -> + false + (** Check whether two types are compatible. *) let compatible_types mode env t1 t2 = @@ -427,7 +463,6 @@ let sizeof_union env members = We lay out fields consecutively, inserting padding to preserve their alignment. Not done here but in composite_info_decl: rounding size to alignment. *) - let sizeof_struct env members = let rec sizeof_rec ofs = function | [] -> @@ -449,6 +484,26 @@ let sizeof_struct env members = end in sizeof_rec 0 members +(* Simplified version to compute offsets on structs without bitfields *) +let struct_layout env members = + let rec struct_layout_rec mem ofs = function + | [] -> + mem + | [ { fld_typ = TArray(_, None, _) } as m ] -> + (* C99: ty[] allowed as last field *) + begin match alignof env m.fld_typ with + | Some a -> ( m.fld_name,align ofs a)::mem + | None -> [] + end + | m :: rem -> + match alignof env m.fld_typ, sizeof env m.fld_typ with + | Some a, Some s -> + let offset = align ofs a in + struct_layout_rec ((m.fld_name,offset)::mem) (offset + s) rem + | _, _ -> [] + in struct_layout_rec [] 0 members + + (* Determine whether a type is incomplete *) let incomplete_type env t = diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index b1f77944..a322bfb1 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -80,6 +80,8 @@ val combine_types : attr_handling -> Env.t -> typ -> typ -> typ option with the same meaning as for [compatible_types]. When two sets of attributes are compatible, the result of [combine_types] carries the union of these two sets of attributes. *) +val equal_types : Env.t -> typ -> typ -> bool + (* Check that the two given types are equal up to typedef use *) (* Size and alignment *) @@ -105,6 +107,8 @@ val composite_info_decl: Env.t -> struct_or_union -> attributes -> Env.composite_info val composite_info_def: Env.t -> struct_or_union -> attributes -> field list -> Env.composite_info +val struct_layout: + Env.t -> field list -> (string * int) list (* Type classification functions *) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 820f90f5..4d3d1d02 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -56,9 +56,11 @@ let elab_loc l = (l.filename, l.lineno) let top_declarations = ref ([] : globdecl list) -let emit_elab loc td = +let emit_elab ?(enter:bool=true) env loc td = let loc = elab_loc loc in - top_declarations := { gdesc = td; gloc = loc } :: !top_declarations + let dec ={ gdesc = td; gloc = loc } in + if enter then Debug.insert_global_declaration env dec; + top_declarations := dec :: !top_declarations let reset() = top_declarations := [] @@ -556,9 +558,9 @@ and elab_parameters env params = | _ -> (* Prototype introduces a new scope *) let (vars, _) = mmap elab_parameter (Env.new_scope env) params in - (* Catch special case f(void) *) + (* Catch special case f(t) where t is void or a typedef to void *) match vars with - | [ ( {name=""}, TVoid _) ] -> Some [] + | [ ( {name=""}, t) ] when is_void_type env t -> Some [] | _ -> Some vars (* Elaboration of a function parameter *) @@ -730,7 +732,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = (* finishing the definition of an incomplete struct or union *) let (ci', env') = elab_struct_or_union_info kind loc env members attrs in (* Emit a global definition for it *) - emit_elab loc (Gcompositedef(kind, tag', attrs, ci'.ci_members)); + emit_elab env' loc (Gcompositedef(kind, tag', attrs, ci'.ci_members)); (* Replace infos but keep same ident *) (tag', Env.add_composite env' tag' ci') | Some(tag', {ci_sizeof = Some _}), Some _ @@ -745,7 +747,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = (* enter it with a new name *) let (tag', env') = Env.enter_composite env tag ci in (* emit it *) - emit_elab loc (Gcompositedecl(kind, tag', attrs)); + emit_elab env' loc (Gcompositedecl(kind, tag', attrs)); (tag', env') | _, Some members -> (* definition of a complete struct or union *) @@ -753,12 +755,12 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = (* enter it, incomplete, with a new name *) let (tag', env') = Env.enter_composite env tag ci1 in (* emit a declaration so that inner structs and unions can refer to it *) - emit_elab loc (Gcompositedecl(kind, tag', attrs)); + emit_elab env' loc (Gcompositedecl(kind, tag', attrs)); (* elaborate the members *) let (ci2, env'') = elab_struct_or_union_info kind loc env' members attrs in (* emit a definition *) - emit_elab loc (Gcompositedef(kind, tag', attrs, ci2.ci_members)); + emit_elab env'' loc (Gcompositedef(kind, tag', attrs, ci2.ci_members)); (* Replace infos but keep same ident *) (tag', Env.add_composite env'' tag' ci2) @@ -809,7 +811,7 @@ and elab_enum only loc tag optmembers attrs env = let (dcls, env') = elab_members env 0L members in let info = { ei_members = dcls; ei_attr = attrs } in let (tag', env'') = Env.enter_enum env' tag info in - emit_elab loc (Genumdef(tag', attrs, dcls)); + emit_elab env' loc (Genumdef(tag', attrs, dcls)); (tag', env'') (* Elaboration of a naked type, e.g. in a cast *) @@ -1312,7 +1314,7 @@ let elab_expr loc env a = let ty = TFun(TInt(IInt, []), None, false, []) in (* Emit an extern declaration for it *) let id = Env.fresh_ident n in - emit_elab loc (Gdecl(Storage_extern, id, ty, None)); + emit_elab env loc (Gdecl(Storage_extern, id, ty, None)); { edesc = EVar id; etyp = ty } | _ -> elab a1 in let bl = List.map elab al in @@ -1784,13 +1786,21 @@ let enter_typedefs loc env sto dl = List.fold_left (fun env (s, ty, init) -> if init <> NO_INIT then error loc "initializer in typedef"; - if redef Env.lookup_typedef env s then - error loc "redefinition of typedef '%s'" s; - if redef Env.lookup_ident env s then - error loc "redefinition of identifier '%s' as different kind of symbol" s; - let (id, env') = Env.enter_typedef env s ty in - emit_elab loc (Gtypedef(id, ty)); - env') env dl + match previous_def Env.lookup_typedef env s with + | Some (s',ty') -> + if equal_types env ty ty' then begin + warning loc "redefinition of typedef '%s'" s; + env + end else begin + error loc "redefinition of typedef '%s' with different type" s; + env + end + | None -> + if redef Env.lookup_ident env s then + error loc "redefinition of identifier '%s' as different kind of symbol" s; + let (id, env') = Env.enter_typedef env s ty in + emit_elab env loc (Gtypedef(id, ty)); + env') env dl let enter_or_refine_ident local loc env s sto ty = if redef Env.lookup_typedef env s then @@ -1865,7 +1875,7 @@ let enter_decdefs local loc env sto dl = ((sto', id, ty', init') :: decls, env2) else begin (* Global definition *) - emit_elab loc (Gdecl(sto', id, ty', init')); + emit_elab env2 loc (Gdecl(sto', id, ty', init')); (decls, env2) end in let (decls, env') = List.fold_left enter_decdef ([], env) dl in @@ -1899,7 +1909,7 @@ let elab_fundef env spec name body loc = let (func_ty, func_init) = __func__type_and_init s in let (func_id, _, env3,func_ty) = enter_or_refine_ident true loc env2 "__func__" Storage_static func_ty in - emit_elab loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); + emit_elab ~enter:false env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); (* Elaborate function body *) let body' = !elab_funbody_f ty_ret env3 body in (* Special treatment of the "main" function *) @@ -1925,7 +1935,7 @@ let elab_fundef env spec name body loc = fd_vararg = vararg; fd_locals = []; fd_body = body'' } in - emit_elab loc (Gfundef fn); + emit_elab env1 loc (Gfundef fn); env1 let elab_kr_fundef env spec name params defs body loc = @@ -1997,7 +2007,7 @@ let rec elab_definition (local: bool) (env: Env.t) (def: Cabs.definition) (* pragma *) | PRAGMA(s, loc) -> - emit_elab loc (Gpragma s); + emit_elab env loc (Gpragma s); ([], env) and elab_definitions local env = function @@ -2224,7 +2234,9 @@ and elab_block_body env ctx sl = | DEFINITION def :: sl1 -> let (dcl, env') = elab_definition true env def in let loc = elab_loc (get_definitionloc def) in - List.map (fun d -> {sdesc = Sdecl d; sloc = loc}) dcl + List.map (fun ((sto,id,ty,_) as d) -> + Debug.insert_local_declaration sto id ty loc; + {sdesc = Sdecl d; sloc = loc}) dcl @ elab_block_body env' ctx sl1 | s :: sl1 -> let s' = elab_stmt env ctx s in @@ -2250,20 +2262,3 @@ let elab_file prog = reset(); ignore (elab_definitions false (Builtins.environment()) prog); elaborated_program() -(* - let rec inf = Datatypes.S inf in - let ast:Cabs.definition list = - Obj.magic - (match Parser.translation_unit_file inf (Lexer.tokens_stream lb) with - | Parser.Parser.Inter.Fail_pr -> - (* Theoretically impossible : implies inconsistencies - between grammars. *) - Cerrors.fatal_error "Internal error while parsing" - | Parser.Parser.Inter.Timeout_pr -> assert false - | Parser.Parser.Inter.Parsed_pr (ast, _ ) -> ast) - in - reset(); - ignore (elab_definitions false (Builtins.environment()) ast); - elaborated_program() -*) - diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index 82e6589c..5cfe74fd 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -20,16 +20,14 @@ open Pre_parser_aux open Cabshelper open Camlcoq -let contexts : string list list ref = ref [] -let lexicon : (string, Cabs.cabsloc -> token) Hashtbl.t = Hashtbl.create 0 +module SMap = Map.Make(String) -let init filename channel : Lexing.lexbuf = - assert (!contexts = []); - Hashtbl.clear lexicon; - List.iter - (fun (key, builder) -> Hashtbl.add lexicon key builder) - [ - ("_Alignas", fun loc -> ALIGNAS loc); +let contexts_stk : (Cabs.cabsloc -> token) SMap.t list ref = ref [] + +let init_ctx = + List.fold_left (fun ctx (key, builder) -> SMap.add key builder ctx) + SMap.empty + [ ("_Alignas", fun loc -> ALIGNAS loc); ("_Alignof", fun loc -> ALIGNOF loc); ("_Bool", fun loc -> UNDERSCORE_BOOL loc); ("__alignof", fun loc -> ALIGNOF loc); @@ -85,37 +83,42 @@ let init filename channel : Lexing.lexbuf = ("void", fun loc -> VOID loc); ("volatile", fun loc -> VOLATILE loc); ("while", fun loc -> WHILE loc); - ]; - - push_context := begin fun () -> contexts := []::!contexts end; - pop_context := begin fun () -> - match !contexts with - | [] -> assert false - | t::q -> List.iter (Hashtbl.remove lexicon) t; - contexts := q + (let id = "__builtin_va_list" in + id, fun loc -> TYPEDEF_NAME (id, ref TypedefId, loc))] + +let _ = + (* See comments in pre_parser_aux.ml *) + open_context := begin fun () -> + contexts_stk := List.hd !contexts_stk::!contexts_stk end; - declare_varname := begin fun id -> - if Hashtbl.mem lexicon id then begin - Hashtbl.add lexicon id (fun loc -> VAR_NAME (id, ref VarId, loc)); - match !contexts with - | [] -> () - | t::q -> contexts := (id::t)::q - end + close_context := begin fun () -> + contexts_stk := List.tl !contexts_stk end; - declare_typename := begin fun id -> - Hashtbl.add lexicon id (fun loc -> TYPEDEF_NAME (id, ref TypedefId, loc)); - match !contexts with - | [] -> () - | t::q -> contexts := (id::t)::q + save_contexts_stk := begin fun () -> + let save = !contexts_stk in + fun () -> contexts_stk := save end; - !declare_typename "__builtin_va_list"; + declare_varname := begin fun id -> + match !contexts_stk with + (* This is the default, so there is no need to have an entry in this case. *) + | ctx::stk -> contexts_stk := SMap.remove id ctx::stk + | [] -> assert false + end; + + declare_typename := begin fun id -> + match !contexts_stk with + | ctx::stk -> + contexts_stk := + SMap.add id (fun loc -> TYPEDEF_NAME (id, ref TypedefId, loc)) ctx::stk + | [] -> assert false + end +let init filename channel : Lexing.lexbuf = let lb = Lexing.from_channel channel in - lb.lex_curr_p <- - {lb.lex_curr_p with pos_fname = filename; pos_lnum = 1}; + lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = filename; pos_lnum = 1}; lb let currentLoc = @@ -337,8 +340,8 @@ rule initial = parse | "," { COMMA(currentLoc lexbuf) } | "." { DOT(currentLoc lexbuf) } | identifier as id { - try Hashtbl.find lexicon id (currentLoc lexbuf) - with Not_found -> VAR_NAME (id, ref VarId, currentLoc lexbuf) } + try SMap.find id (List.hd !contexts_stk) (currentLoc lexbuf) + with Not_found -> VAR_NAME (id, ref VarId, currentLoc lexbuf) } | eof { EOF } | _ as c { fatal_error lexbuf "invalid symbol %C" c } @@ -435,7 +438,7 @@ and singleline_comment = parse open Parser open Aut.GramDefs - let tokens_stream lexbuf : token coq_Stream = + let tokens_stream filename channel : token coq_Stream = let tokens = Queue.create () in let lexer_wraper lexbuf : Pre_parser.token = let res = @@ -447,8 +450,11 @@ and singleline_comment = parse Queue.push res tokens; res in + let lexbuf = Lexing.from_channel channel in + lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = filename; pos_lnum = 1}; + contexts_stk := [init_ctx]; Pre_parser.translation_unit_file lexer_wraper lexbuf; - assert (!contexts = []); + assert (List.length !contexts_stk = 1); let rec compute_token_stream () = let loop t v = Cons (Coq_existT (t, Obj.magic v), Lazy.from_fun compute_token_stream) diff --git a/cparser/Parse.ml b/cparser/Parse.ml index c9564c08..cfa95688 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -24,12 +24,7 @@ let transform_program t p name = (run_pass Unblock.program 'b' (run_pass Bitfields.program 'f' p)))) in - let debug = - if !Clflags.option_g && Configuration.advanced_debug then - Some (CtoDwarf.program_to_dwarf p p1 name) - else - None in - (Rename.program p1 (Filename.chop_suffix name ".c")),debug + (Rename.program p1 (Filename.chop_suffix name ".c")) let parse_transformations s = let t = ref CharSet.empty in @@ -46,15 +41,19 @@ let parse_transformations s = let preprocessed_file transfs name sourcefile = Cerrors.reset(); let ic = open_in sourcefile in - let p,d = + let p = try let t = parse_transformations transfs in - let lb = Lexer.init name ic in let rec inf = Datatypes.S inf in let ast : Cabs.definition list = Obj.magic - (match Timing.time2 "Parsing" - Parser.translation_unit_file inf (Lexer.tokens_stream lb) with + (match Timing.time "Parsing" + (* The call to Lexer.tokens_stream results in the pre + parsing of the entire file. This is non-negligeabe, + so we cannot use Timing.time2 *) + (fun () -> + Parser.translation_unit_file inf (Lexer.tokens_stream name ic)) () + with | Parser.Parser.Inter.Fail_pr -> (* Theoretically impossible : implies inconsistencies between grammars. *) @@ -65,6 +64,6 @@ let preprocessed_file transfs name sourcefile = Timing.time2 "Emulations" transform_program t p1 name with | Cerrors.Abort -> - [],None in + [] in close_in ic; - if Cerrors.check_errors() then None,None else Some p,d + if Cerrors.check_errors() then None else Some p diff --git a/cparser/Parse.mli b/cparser/Parse.mli index ac8feb70..58c3cfb9 100644 --- a/cparser/Parse.mli +++ b/cparser/Parse.mli @@ -15,7 +15,7 @@ (* Entry point for the library: parse, elaborate, and transform *) -val preprocessed_file: string -> string -> string -> C.program option * DwarfTypes.dw_entry option +val preprocessed_file: string -> string -> string -> C.program option (* first arg: desired transformations second arg: source file name before preprocessing diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index 91f50552..c6646b5c 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -177,16 +177,89 @@ and expand_init islocal env i = in expand i +(* Insertion of debug annotation, for -g mode *) + +let debug_id = Env.fresh_ident "__builtin_debug" +let debug_ty = + TFun(TVoid [], Some [Env.fresh_ident "kind", TInt(IInt, [])], true, []) + +let debug_annot kind args = + { sloc = no_loc; + sdesc = Sdo { + etyp = TVoid []; + edesc = ECall({edesc = EVar debug_id; etyp = debug_ty}, + intconst kind IInt :: args) + } + } + +let string_const str = + let c = CStr str in { edesc = EConst c; etyp = type_of_constant c } + +let integer_const n = + intconst (Int64.of_int n) IInt + +(* Line number annotation: + __builtin_debug(1, "#line:filename:lineno") *) +(* TODO: consider + __builtin_debug(1, "filename", lineno) + instead. *) + +let debug_lineno (filename, lineno) = + debug_annot 1L + [string_const (Printf.sprintf "#line:%s:%d" filename lineno)] + +(* Scope annotation: + __builtin_debug(6, "", scope1, scope2, ..., scopeN) +*) + +let empty_string = string_const "" + +let curr_fun_id = ref 0 + +let debug_var_decl ctx id = + Debug.add_lvar_scope !curr_fun_id id (List.hd ctx) + +let debug_scope ctx = + debug_annot 6L (empty_string :: List.rev_map integer_const ctx) + +(* Add line number debug annotation if the line number changes. + Add scope debug annotation regardless. *) + + +let add_lineno ctx prev_loc this_loc s = + if !Clflags.option_g then + sseq no_loc (debug_scope ctx) + (if this_loc <> prev_loc && this_loc <> no_loc + then sseq no_loc (debug_lineno this_loc) s + else s) + else s + +(* Generate fresh scope identifiers, for blocks that contain at least + one declaration *) + +let block_contains_decl sl = + List.exists + (function {sdesc = Sdecl _} -> true | _ -> false) + sl + +let next_scope_id = ref 0 + +let new_scope_id () = + incr next_scope_id; !next_scope_id + (* Process a block-scoped variable declaration. The variable is entered in [local_variables]. The initializer, if any, is converted into assignments and prepended to [k]. *) -let process_decl loc env (sto, id, ty, optinit) k = +let process_decl loc env ctx (sto, id, ty, optinit) k = let ty' = remove_const env ty in local_variables := (sto, id, ty', None) :: !local_variables; + debug_var_decl ctx id; + (* TODO: register the fact that id is declared in scope ctx *) match optinit with - | None -> k + | None -> + k | Some init -> let init' = expand_init true env init in let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in @@ -194,57 +267,90 @@ let process_decl loc env (sto, id, ty, optinit) k = (* Simplification of blocks within a statement *) -let rec unblock_stmt env s = +let rec unblock_stmt env ctx ploc s = match s.sdesc with | Sskip -> s | Sdo e -> - {s with sdesc = Sdo(expand_expr true env e)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sdo(expand_expr true env e)} | Sseq(s1, s2) -> - {s with sdesc = Sseq(unblock_stmt env s1, unblock_stmt env s2)} + {s with sdesc = Sseq(unblock_stmt env ctx ploc s1, + unblock_stmt env ctx s1.sloc s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(expand_expr true env e, - unblock_stmt env s1, unblock_stmt env s2)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sif(expand_expr true env e, + unblock_stmt env ctx s.sloc s1, + unblock_stmt env ctx s.sloc s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(expand_expr true env e, unblock_stmt env s1)} + add_lineno ctx ploc s.sloc + {s with sdesc = Swhile(expand_expr true env e, + unblock_stmt env ctx s.sloc s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(unblock_stmt env s1, expand_expr true env e)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sdowhile(unblock_stmt env ctx s.sloc s1, + expand_expr true env e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(unblock_stmt env s1, - expand_expr true env e, - unblock_stmt env s2, - unblock_stmt env s3)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sfor(unblock_stmt env ctx s.sloc s1, + expand_expr true env e, + unblock_stmt env ctx s.sloc s2, + unblock_stmt env ctx s.sloc s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(expand_expr true env e, unblock_stmt env s1)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sswitch(expand_expr true env e, + unblock_stmt env ctx s.sloc s1)} | Slabeled(lbl, s1) -> - {s with sdesc = Slabeled(lbl, unblock_stmt env s1)} - | Sgoto lbl -> s - | Sreturn None -> s + add_lineno ctx ploc s.sloc + {s with sdesc = Slabeled(lbl, unblock_stmt env ctx s.sloc s1)} + | Sgoto lbl -> + add_lineno ctx ploc s.sloc s + | Sreturn None -> + add_lineno ctx ploc s.sloc s | Sreturn (Some e) -> - {s with sdesc = Sreturn(Some (expand_expr true env e))} - | Sblock sl -> unblock_block env sl - | Sdecl d -> assert false + add_lineno ctx ploc s.sloc + {s with sdesc = Sreturn(Some (expand_expr true env e))} + | Sblock sl -> + let ctx' = + if block_contains_decl sl + then + let id = new_scope_id () in + (match ctx with + | [] -> Debug.enter_function_scope !curr_fun_id id + | a::_ -> Debug.enter_scope !curr_fun_id a id); + id:: ctx + else ctx in + unblock_block env ctx' ploc sl + | Sdecl d -> + assert false | Sasm(attr, template, outputs, inputs, clob) -> let expand_asm_operand (lbl, cstr, e) = (lbl, cstr, expand_expr true env e) in - {s with sdesc = Sasm(attr, template, - List.map expand_asm_operand outputs, - List.map expand_asm_operand inputs, clob)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sasm(attr, template, + List.map expand_asm_operand outputs, + List.map expand_asm_operand inputs, clob)} -and unblock_block env = function +and unblock_block env ctx ploc = function | [] -> sskip | {sdesc = Sdecl d; sloc = loc} :: sl -> - process_decl loc env d (unblock_block env sl) + add_lineno ctx ploc loc + (process_decl loc env ctx d + (unblock_block env ctx loc sl)) | s :: sl -> - sseq s.sloc (unblock_stmt env s) (unblock_block env sl) + sseq s.sloc (unblock_stmt env ctx ploc s) + (unblock_block env ctx s.sloc sl) (* Simplification of blocks and compound literals within a function *) let unblock_fundef env f = local_variables := []; - let body = unblock_stmt env f.fd_body in + next_scope_id := 0; + curr_fun_id:= f.fd_name.stamp; + (* TODO: register the parameters as being declared in function scope *) + let body = unblock_stmt env [] no_loc f.fd_body in let decls = !local_variables in local_variables := []; { f with fd_locals = f.fd_locals @ decls; fd_body = body } @@ -299,4 +405,5 @@ let rec unblock_glob env accu = function (* Entry point *) let program p = + {gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} :: unblock_glob (Builtins.environment()) [] p diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly index 44a06f8a..e73cc22a 100644 --- a/cparser/pre_parser.mly +++ b/cparser/pre_parser.mly @@ -57,9 +57,14 @@ (* These precedences declarations solve the conflict in the following declaration : -int f(int (a)); + int f(int (a)); -when a is a TYPEDEF_NAME. It is specified by 6.7.5.3 11. + when a is a TYPEDEF_NAME. It is specified by 6.7.5.3 11. + + WARNING: These precedence declarations tend to silently solve other + conflicts. So, if you change the grammar (especially or + statements), you should check that without these declarations, it + has ONLY ONE CONFLICT. *) %nonassoc TYPEDEF_NAME %nonassoc highPrec @@ -89,25 +94,30 @@ string_literals_list: | string_literals_list STRING_LITERAL {} -(* WARNING : because of the lookahead token, the context might - be pushed or popped one token after the position of this - non-terminal ! +(* WARNING : because of the lookahead token, the context might be + opened or closed one token after the position of this non-terminal ! - Pushing too late is not dangerous for us, because this does not + Opening too late is not dangerous for us, because this does not change the token stream. However, we have to make sure the - lookahead token present just after popping is not an identifier. - *) + lookahead token present just after closing/declaring/restoring is + not an identifier. An easy way to check that is to look at the + follow set of the non-terminal in question. The follow sets are + given by menhir with option -lg 3. *) + +%inline nop: (* empty *) { } -push_context: - (* empty *)%prec highPrec { !push_context () } -pop_context: - (* empty *) { !pop_context () } +open_context: + (* empty *)%prec highPrec { !open_context () } +close_context: + (* empty *) { !close_context () } in_context(nt): - push_context x = nt pop_context { x } + open_context x = nt close_context { x } + +save_contexts_stk: + (* empty *) { !save_contexts_stk () } declare_varname(nt): i = nt { declare_varname i; i } - declare_typename(nt): i = nt { declare_typename i; i } @@ -267,39 +277,20 @@ constant_expression: | conditional_expression {} +(* We separate two kinds of declarations: the typedef declaration and + the normal declarations. This makes possible to distinguish /in the + grammar/ whether a declaration should add a typename or a varname + in the context. There is an other difference between + [init_declarator_list] and [typedef_declarator_list]: the later + cannot contain an initialization (this is an error to initialize a + typedef). *) + declaration: | declaration_specifiers init_declarator_list? SEMICOLON {} | declaration_specifiers_typedef typedef_declarator_list? SEMICOLON {} -declaration_specifiers_no_type: -| storage_class_specifier_no_typedef declaration_specifiers_no_type? -| type_qualifier declaration_specifiers_no_type? -| function_specifier declaration_specifiers_no_type? - {} - -declaration_specifiers_no_typedef_name: -| storage_class_specifier_no_typedef declaration_specifiers_no_typedef_name? -| type_qualifier declaration_specifiers_no_typedef_name? -| function_specifier declaration_specifiers_no_typedef_name? -| type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? - {} - -declaration_specifiers: -| declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type? - { set_id_type i TypedefId } -| declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? - {} - -declaration_specifiers_typedef: -| declaration_specifiers_no_type? TYPEDEF declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type? -| declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type? TYPEDEF declaration_specifiers_no_type? - { set_id_type i TypedefId } -| declaration_specifiers_no_type? TYPEDEF declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? -| declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? TYPEDEF declaration_specifiers_no_typedef_name? - {} - init_declarator_list: | init_declarator | init_declarator_list COMMA init_declarator @@ -326,6 +317,67 @@ storage_class_specifier_no_typedef: | REGISTER {} +(* [declaration_specifiers_no_type] matches declaration specifiers + that do not contain either "typedef" nor type specifiers. *) +declaration_specifiers_no_type: +| storage_class_specifier_no_typedef declaration_specifiers_no_type? +| type_qualifier declaration_specifiers_no_type? +| function_specifier declaration_specifiers_no_type? + {} + +(* [declaration_specifiers_no_typedef_name] matches declaration + specifiers that contain neither "typedef" nor a typedef name + (i.e. type specifier declared using a previous "typedef + keyword"). *) +declaration_specifiers_no_typedef_name: +| storage_class_specifier_no_typedef declaration_specifiers_no_typedef_name? +| type_qualifier declaration_specifiers_no_typedef_name? +| function_specifier declaration_specifiers_no_typedef_name? +| type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? + {} + +(* [declaration_specifiers_no_type] matches declaration_specifiers + that do not contains "typedef". Moreover, it makes sure that it + contains either one typename and not other type specifier or no + typename. + + This is a weaker condition than 6.7.2 2. It is necessary to enforce + this in the grammar to disambiguate the example in 6.7.7 6: + + typedef signed int t; + struct tag { + unsigned t:4; + const t:5; + }; + + The first field is a named t, while the second is unnamed of type t. +*) +declaration_specifiers: +| declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type? + { set_id_type i TypedefId } +| declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? + {} + +(* This matches declaration_specifiers that do contains once the + "typedef" keyword. To avoid conflicts, we also encode the + constraint described in the comment for [declaration_specifiers]. *) +declaration_specifiers_typedef: +| declaration_specifiers_no_type? + TYPEDEF declaration_specifiers_no_type? + i = TYPEDEF_NAME declaration_specifiers_no_type? +| declaration_specifiers_no_type? + i = TYPEDEF_NAME declaration_specifiers_no_type? + TYPEDEF declaration_specifiers_no_type? + { set_id_type i TypedefId } +| declaration_specifiers_no_type? + TYPEDEF declaration_specifiers_no_type? + type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? +| declaration_specifiers_no_type? + type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? + TYPEDEF declaration_specifiers_no_typedef_name? + {} + +(* A type specifier which is not a typedef name. *) type_specifier_no_typedef_name: | VOID | CHAR @@ -366,6 +418,8 @@ struct_declaration: | specifier_qualifier_list struct_declarator_list? SEMICOLON {} +(* As in the standard, except it also encodes the constraint described + in the comment above [declaration_specifiers]. *) specifier_qualifier_list: | type_qualifier_list? i = TYPEDEF_NAME type_qualifier_list? { set_id_type i TypedefId } @@ -460,6 +514,10 @@ function_specifier: | INLINE {} +(* The semantic action returned by [declarator] is a pair of the + identifier being defined and an option of the context stack that + has to be restored if entering the body of the function being + defined, if so. *) declarator: | pointer? x = direct_declarator attribute_specifier_list { x } @@ -470,9 +528,11 @@ direct_declarator: | LPAREN x = declarator RPAREN | x = direct_declarator LBRACK type_qualifier_list? assignment_expression? RBRACK { x } -| x = direct_declarator LPAREN l=in_context(parameter_type_list?) RPAREN +| x = direct_declarator LPAREN + open_context parameter_type_list? restore_fun = save_contexts_stk + close_context RPAREN { match snd x with - | None -> (fst x, Some (match l with None -> [] | Some l -> l)) + | None -> (fst x, Some restore_fun) | Some _ -> x } pointer: @@ -542,26 +602,51 @@ designator: | DOT i = general_identifier { set_id_type i OtherId } -statement_finish: -| labeled_statement(statement_finish) -| compound_statement -| expression_statement -| selection_statement_finish -| iteration_statement(statement_finish) -| jump_statement -| asm_statement - {} +(* The grammar of statements is replicated three times. -statement_intern: -| labeled_statement(statement_intern) -| compound_statement -| expression_statement -| selection_statement_intern -| iteration_statement(statement_intern) -| jump_statement -| asm_statement - {} + [statement_finish_close] should close the current context just + before its last token. + [statement_finish_noclose] should not close the current context. It + should modify it only if this modification actually changes the + context of the current block. + + [statement_intern_close] is like [statement_finish_close], except + it cannot reduce to a single-branch if statement. +*) + +statement_finish_close: +| labeled_statement(statement_finish_close) +| compound_statement(nop) +| expression_statement(close_context) +| selection_statement_finish(nop) +| iteration_statement(nop,statement_finish_close) +| jump_statement(close_context) +| asm_statement(close_context) + {} + +statement_finish_noclose: +| labeled_statement(statement_finish_noclose) +| compound_statement(open_context) +| expression_statement(nop) +| selection_statement_finish(open_context) +| iteration_statement(open_context,statement_finish_close) +| jump_statement(nop) +| asm_statement(nop) + {} + +statement_intern_close: +| labeled_statement(statement_intern_close) +| compound_statement(nop) +| expression_statement(close_context) +| selection_statement_intern_close +| iteration_statement(nop,statement_intern_close) +| jump_statement(close_context) +| asm_statement(close_context) + {} + +(* [labeled_statement(last_statement)] has the same effect on contexts + as [last_statement]. *) labeled_statement(last_statement): | i = general_identifier COLON last_statement { set_id_type i OtherId } @@ -569,10 +654,14 @@ labeled_statement(last_statement): | DEFAULT COLON last_statement {} -compound_statement: -| LBRACE in_context(block_item_list?) RBRACE +(* [compound_statement] uses a local context and closes it before its + last token. It uses [openc] to open this local context if needed. + That is, if a local context has already been opened, [openc] = [nop], + otherwise, [openc] = [open_context]. *) +compound_statement(openc): +| LBRACE openc block_item_list? close_context RBRACE {} -| LBRACE in_context(block_item_list?) error +| LBRACE openc block_item_list? close_context error { unclosed "{" "}" $startpos($1) $endpos } block_item_list: @@ -581,47 +670,99 @@ block_item_list: block_item: | declaration -| statement_finish +| statement_finish_noclose | PRAGMA {} -expression_statement: -| expression? SEMICOLON +(* [expression_statement], [jump_statement] and [asm_statement] close + the local context if needed, depending of the close parameter. If + there is no local context, [close] = [nop]. Otherwise, + [close] = [close_context]. *) +expression_statement(close): +| expression? close SEMICOLON {} -selection_statement_finish: -| IF LPAREN expression RPAREN statement_finish -| IF LPAREN expression RPAREN statement_intern ELSE statement_finish -| SWITCH LPAREN expression RPAREN statement_finish +jump_statement(close): +| GOTO i = general_identifier close SEMICOLON + { set_id_type i OtherId } +| CONTINUE close SEMICOLON +| BREAK close SEMICOLON +| RETURN expression? close SEMICOLON {} -selection_statement_intern: -| IF LPAREN expression RPAREN statement_intern ELSE statement_intern -| SWITCH LPAREN expression RPAREN statement_intern +asm_statement(close): +| ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN close SEMICOLON {} -iteration_statement(stmt): -| WHILE LPAREN expression RPAREN stmt -| DO statement_finish WHILE LPAREN expression RPAREN SEMICOLON -| FOR LPAREN expression? SEMICOLON expression? SEMICOLON expression? RPAREN stmt -| FOR LPAREN push_context declaration expression? SEMICOLON expression? RPAREN stmt pop_context +(* [selection_statement_finish] and [selection_statement_intern] use a + local context and close it before their last token. + + [selection_statement_finish(openc)] uses [openc] to open this local + context if needed. That is, if a local context has already been + opened, [openc] = [nop], otherwise, [openc] = [open_context]. + + [selection_statement_intern_close] is always called with a local + context openned. It closes it before its last token. *) + +(* It should be noted that the token [ELSE] should be lookaheaded + /outside/ of the local context because if the lookaheaded token is + not [ELSE], then this is the end of the statement. + + This is especially important to parse correctly the following + example: + + typedef int a; + + int f() { + for(int a; ;) + if(1); + a * x; + } + + However, if the lookahead token is [ELSE], we should parse the + second branch in the same context as the first branch, so we have + to reopen the previously closed context. This is the reason for the + save/restore system. +*) + +if_else_statement_begin(openc): +| IF openc LPAREN expression RPAREN restore_fun = save_contexts_stk + statement_intern_close + { restore_fun () } + +selection_statement_finish(openc): +| IF openc LPAREN expression RPAREN save_contexts_stk statement_finish_close +| if_else_statement_begin(openc) ELSE statement_finish_close +| SWITCH openc LPAREN expression RPAREN statement_finish_close {} -jump_statement: -| GOTO i = general_identifier SEMICOLON - { set_id_type i OtherId } -| CONTINUE SEMICOLON -| BREAK SEMICOLON -| RETURN expression? SEMICOLON +selection_statement_intern_close: +| if_else_statement_begin(nop) ELSE statement_intern_close +| SWITCH LPAREN expression RPAREN statement_intern_close {} -asm_statement: -| ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN SEMICOLON +(* [iteration_statement] uses a local context and closes it before + their last token. + + [iteration_statement] uses [openc] to open this local context if + needed. That is, if a local context has already been opened, + [openc] = [nop], otherwise, [openc] = [open_context]. + + [last_statement] is either [statement_intern_close] or + [statement_finish_close]. That is, it should /always/ close the + local context. *) + +iteration_statement(openc,last_statement): +| WHILE openc LPAREN expression RPAREN last_statement +| DO open_context statement_finish_close WHILE + openc LPAREN expression RPAREN close_context SEMICOLON +| FOR openc LPAREN expression? SEMICOLON expression? SEMICOLON expression? RPAREN last_statement +| FOR openc LPAREN declaration expression? SEMICOLON expression? RPAREN last_statement {} asm_attributes: | /* empty */ -| CONST asm_attributes +| CONST asm_attributes | VOLATILE asm_attributes {} @@ -679,22 +820,14 @@ function_definition_begin: | declaration_specifiers pointer? x=direct_declarator { match x with | (_, None) -> $syntaxerror - | (i, Some l) -> - declare_varname i; - !push_context (); - List.iter (fun x -> - match x with - | None -> () - | Some i -> declare_varname i - ) l + | (i, Some restore_fun) -> restore_fun () } -| declaration_specifiers pointer? x=direct_declarator - LPAREN params=identifier_list RPAREN in_context(declaration_list) +| declaration_specifiers pointer? x=direct_declarator + LPAREN params=identifier_list RPAREN open_context declaration_list { match x with | (_, Some _) -> $syntaxerror | (i, None) -> declare_varname i; - !push_context (); List.iter declare_varname params } @@ -711,8 +844,7 @@ declaration_list: { } function_definition: -| function_definition_begin LBRACE block_item_list? pop_context RBRACE +| function_definition_begin LBRACE block_item_list? close_context RBRACE { } -| function_definition_begin LBRACE block_item_list? pop_context error +| function_definition_begin LBRACE block_item_list? close_context error { unclosed "{" "}" $startpos($2) $endpos } - diff --git a/cparser/pre_parser_aux.ml b/cparser/pre_parser_aux.ml index 55dfdfde..c6b48608 100644 --- a/cparser/pre_parser_aux.ml +++ b/cparser/pre_parser_aux.ml @@ -18,8 +18,20 @@ type identifier_type = | TypedefId | OtherId -let push_context:(unit -> unit) ref= ref (fun () -> assert false) -let pop_context:(unit -> unit) ref = ref (fun () -> assert false) +(* These functions push and pop a context on the contexts stack. *) +let open_context:(unit -> unit) ref = ref (fun () -> assert false) +let close_context:(unit -> unit) ref = ref (fun () -> assert false) +(* Applying once this functions saves the whole contexts stack, and + applying it the second time restores it. + + This is mainly used to rollback the context stack to a previous + state. This is usefull for example when we pop too much contexts at + the end of the first branch of an if statement. See + pre_parser.mly. *) +let save_contexts_stk:(unit -> (unit -> unit)) ref = ref (fun _ -> assert false) + +(* Change the context at the top of the top stack of context, by + changing an identifier to be a varname or a typename*) let declare_varname:(string -> unit) ref = ref (fun _ -> assert false) let declare_typename:(string -> unit) ref = ref (fun _ -> assert false) diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml deleted file mode 100644 index c2085eb0..00000000 --- a/debug/CtoDwarf.ml +++ /dev/null @@ -1,543 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) -(* is distributed under the terms of the INRIA Non-Commercial *) -(* License Agreement. *) -(* *) -(* *********************************************************************) - -open Builtins -open C -open Cprint -open Cutil -open C2C -open DwarfTypes -open DwarfUtil -open Env -open Set - -(* Functions to translate a C Ast into Dwarf 2 debugging information *) - - -(* Hashtable from type name to entry id *) -let type_table: (string, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable for typedefname to entry id *) -let typedef_table: (string, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable from composite table to entry id *) -let composite_types_table: (int, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable from id of a defined composite types to minimal type info *) -let composite_declarations: (int, (struct_or_union * string * location)) Hashtbl.t = Hashtbl.create 7 - -module IntSet = Set.Make(struct type t = int let compare = compare end) - -(* Set of all declared composite_types *) -let composite_defined: IntSet.t ref = ref IntSet.empty - -(* Get the type id of a composite_type *) -let get_composite_type (name: int): int = - try - Hashtbl.find composite_types_table name - with Not_found -> - let id = next_id () in - Hashtbl.add composite_types_table name id; - id - -(* Translate a C.typ to a string needed for hashing *) -let typ_to_string (ty: typ) = - let buf = Buffer.create 7 in - let chan = Format.formatter_of_buffer buf in - typ chan ty; - Format.pp_print_flush chan (); - Buffer.contents buf - -let rec mmap f env = function - | [] -> ([],env) - | hd :: tl -> - let (hd',env1) = f env hd in - let (tl', env2) = mmap f env1 tl in - (hd' :: tl', env2) - - -(* Helper functions for the attributes *) - -let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in - match typ with - | TVoid at -> TVoid (strip at) - | TInt (k,at) -> TInt (k,strip at) - | TFloat (k,at) -> TFloat(k,strip at) - | TPtr (t,at) -> TPtr(t,strip at) - | TArray (t,s,at) -> TArray(t,s,strip at) - | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) - | TNamed (n,at) -> TNamed(n,strip at) - | TStruct (n,at) -> TStruct(n,strip at) - | TUnion (n,at) -> TUnion(n,strip at) - | TEnum (n,at) -> TEnum(n,strip at) - - -let strip_last_attribute typ = - let rec hd_opt l = match l with - [] -> None,[] - | AConst::rest -> Some AConst,rest - | AVolatile::rest -> Some AVolatile,rest - | _::rest -> hd_opt rest in - match typ with - | TVoid at -> let l,r = hd_opt at in - l,TVoid r - | TInt (k,at) -> let l,r = hd_opt at in - l,TInt (k,r) - | TFloat (k,at) -> let l,r = hd_opt at in - l,TFloat (k,r) - | TPtr (t,at) -> let l,r = hd_opt at in - l,TPtr(t,r) - | TArray (t,s,at) -> let l,r = hd_opt at in - l,TArray(t,s,r) - | TFun (t,arg,v,at) -> let l,r = hd_opt at in - l,TFun(t,arg,v,r) - | TNamed (n,at) -> let l,r = hd_opt at in - l,TNamed(n,r) - | TStruct (n,at) -> let l,r = hd_opt at in - l,TStruct(n,r) - | TUnion (n,at) -> let l,r = hd_opt at in - l,TUnion(n,r) - | TEnum (n,at) -> let l,r = hd_opt at in - l,TEnum(n,r) - -(* Dwarf tag for the void type*) -let rec void_dwarf_tag = - let void = { - base_type_byte_size = 0; - base_type_encoding = None; - base_type_name = "void"; - } in - DW_TAG_base_type void - -(* Generate a dwarf tag for the given integer type *) -and int_to_dwarf_tag k = - let encoding = - (match k with - | IBool -> DW_ATE_boolean - | IChar -> - if !Machine.config.Machine.char_signed then - DW_ATE_signed_char - else - DW_ATE_unsigned_char - | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed_char - | _ -> DW_ATE_unsigned)in - let int = { - base_type_byte_size = sizeof_ikind k; - base_type_encoding = Some encoding; - base_type_name = typ_to_string (TInt (k,[]));} in - DW_TAG_base_type int - -(* Generate a dwarf tag for the given floating point type *) -and float_to_dwarf_tag k = - let byte_size = sizeof_fkind k in - let float = { - base_type_byte_size = byte_size; - base_type_encoding = Some DW_ATE_float; - base_type_name = typ_to_string (TFloat (k,[])); - } in - DW_TAG_base_type float - -(* Generate a dwarf tag for the given function type *) -and fun_to_dwarf_tag rt args = - let ret,et = (match rt with - | TVoid _ -> None,[] - | _ -> let ret,et = type_to_dwarf rt in - Some ret,et) in - let prototyped,children,others = - (match args with - | None -> - let u = { - unspecified_parameter_file_loc = None; - unspecified_parameter_artificial = None; - } in - let u = new_entry (DW_TAG_unspecified_parameter u) in - false,[u],[] - | Some [] -> true,[],[] - | Some l -> - let c,e = mmap (fun acc (_,t) -> - let t,e = type_to_dwarf t in - let fp = - { - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_location = None; - formal_parameter_name = None; - formal_parameter_segment = None; - formal_parameter_type = t; - formal_parameter_variable_parameter = None; - } in - let entry = new_entry (DW_TAG_formal_parameter fp) in - entry,(e@acc)) [] l in - true,c,e) in - let s = { - subroutine_type = ret; - subroutine_prototyped = prototyped; - } in - let s = new_entry (DW_TAG_subroutine_type s) in - let s = add_children s children in - s.id,((s::others)@et) - -(* Generate a dwarf tag for the given array type *) -and array_to_dwarf_tag child size = - let append_opt a b = - match a with - | None -> b - | Some a -> a::b in - let size_to_subrange s = - match s with - | None -> None - | Some i -> - let i = Int64.to_int (Int64.sub i Int64.one) in - let s = - { - subrange_type = None; - subrange_upper_bound = Some (BoundConst i); - } in - Some (new_entry (DW_TAG_subrange_type s)) in - let rec aux t = - (match t with - | TArray (child,size,_) -> - let sub = size_to_subrange size in - let t,c,e = aux child in - t,append_opt sub c,e - | _ -> let t,e = type_to_dwarf t in - t,[],e) in - let t,children,e = aux child in - let sub = size_to_subrange size in - let children = List.rev (append_opt sub children) in - let arr = { - array_type_file_loc = None; - array_type = t; - } in - let arr = new_entry (DW_TAG_array_type arr) in - let arr = add_children arr children in - arr.id,(arr::e) - -(* Translate a typ without attributes to a dwarf_tag *) -and type_to_dwarf_entry typ typ_string= - let id,entries = - (match typ with - | TVoid _ -> - let e = new_entry void_dwarf_tag in - e.id,[e] - | TInt (k,_) -> - let e = new_entry (int_to_dwarf_tag k) in - e.id,[e] - | TFloat (k,_) -> - let e = new_entry (float_to_dwarf_tag k) in - e.id,[e] - | TPtr (t,_) -> - let t,e = type_to_dwarf t in - let pointer = {pointer_type = t;} in - let t = new_entry (DW_TAG_pointer_type pointer) in - t.id,t::e - | TFun (rt,args,_,_) -> fun_to_dwarf_tag rt args - | TStruct (i,_) - | TUnion (i,_) - | TEnum (i,_) -> - let t = get_composite_type i.stamp in - t,[] - | TNamed (i,at) -> - let t = Hashtbl.find typedef_table i.name in - t,[] - | TArray (child,size,_) -> array_to_dwarf_tag child size) - in - Hashtbl.add type_table typ_string id; - id,entries - -(* Tranlate type with attributes to their corresponding dwarf represenation *) -and attr_type_to_dwarf typ typ_string = - let l,t = strip_last_attribute typ in - match l with - | Some AConst -> let id,t = type_to_dwarf t in - let const_tag = DW_TAG_const_type ({const_type = id;}) in - let const_entry = new_entry const_tag in - let id = const_entry.id in - Hashtbl.add type_table typ_string id; - id,const_entry::t - | Some AVolatile -> let id,t = type_to_dwarf t in - let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in - let volatile_entry = new_entry volatile_tag in - let id = volatile_entry.id in - Hashtbl.add type_table typ_string id; - id,volatile_entry::t - | Some (ARestrict|AAlignas _| Attr(_,_)) -> type_to_dwarf t (* This should not happen *) - | None -> type_to_dwarf_entry typ typ_string - -(* Translate a given type to its dwarf representation *) -and type_to_dwarf (typ: typ): int * dw_entry list = - match typ with - | TStruct (i,_) - | TUnion (i,_) - | TEnum (i,_) -> - let t = get_composite_type i.stamp in - t,[] - | _ -> - let typ = strip_attributes typ in - let typ_string = typ_to_string typ in - try - Hashtbl.find type_table typ_string,[] - with Not_found -> - attr_type_to_dwarf typ typ_string - -(* Translate a typedef to its corresponding dwarf representation *) -let typedef_to_dwarf gloc (name,t) = - let i,t = type_to_dwarf t in - let td = { - typedef_file_loc = gloc; - typedef_name = name; - typedef_type = i; - } in - let td = new_entry (DW_TAG_typedef td) in - Hashtbl.add typedef_table name td.id; - td::t - -(* Translate a global var to its corresponding dwarf representation *) -let glob_var_to_dwarf (s,n,t,_) gloc = - let i,t = type_to_dwarf t in - let ext = (match s with - | Storage_static -> false - | _ -> true) in - let decl = { - variable_file_loc = (Some gloc); - variable_declaration = None; - variable_external = Some ext; - variable_location = None; - variable_name = n.name; - variable_segment = None; - variable_type = i; - } in - let decl = new_entry (DW_TAG_variable decl) in - t,decl - -(* Translate a function definition to its corresponding dwarf representation *) -let fundef_to_dwarf f gloc = - let ret,e = (match f.fd_ret with - | TVoid _ -> None,[] - | _ -> let i,t = type_to_dwarf f.fd_ret in - Some i,t) in - let ext = (match f.fd_storage with - | Storage_static -> false - | _ -> true) in - let fdef = { - subprogram_file_loc = (Some gloc); - subprogram_external = Some ext; - subprogram_frame_base = None; - subprogram_name = f.fd_name.name; - subprogram_prototyped = true; - subprogram_type = ret; - } in - let fp,e = mmap (fun acc (p,t) -> - let t,e = type_to_dwarf t in - let fp = - { - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_location = None; - formal_parameter_name = (Some p.name); - formal_parameter_segment = None; - formal_parameter_type = t; - formal_parameter_variable_parameter = None; - } in - let entry = new_entry (DW_TAG_formal_parameter fp) in - entry,(e@acc)) e f.fd_params in - let fdef = new_entry (DW_TAG_subprogram fdef) in - let fdef = add_children fdef fp in - e,fdef - -(* Translate a enum definition to its corresponding dwarf representation *) -let enum_to_dwarf (n,at,e) gloc = - let enumerator_to_dwarf (i,c,_)= - let tag = - { - enumerator_file_loc = None; - enumerator_value = Int64.to_int c; - enumerator_name = i.name; - } in - new_entry (DW_TAG_enumerator tag) in - let bs = sizeof_ikind enum_ikind in - let enum = { - enumeration_file_loc = Some gloc; - enumeration_byte_size = bs; - enumeration_declaration = None; - enumeration_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let child = List.map enumerator_to_dwarf e in - let enum = - { - tag = DW_TAG_enumeration_type enum; - children = child; - id = id; - } in - [enum] - -(* Translate a struct definition to its corresponding dwarf representation *) -let struct_to_dwarf (n,at,m) env gloc = - let info = Env.find_struct env n in - let tag =DW_TAG_structure_type { - structure_file_loc = Some gloc; - structure_byte_size = info.ci_sizeof; - structure_declaration = None; - structure_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let rec pack acc bcc l m = - match m with - | [] -> acc,bcc,[] - | m::ms as ml -> - (match m.fld_bitfield with - | None -> acc,bcc,ml - | Some n -> - if n = 0 then - acc,bcc,ms (* bit width 0 means end of pack *) - else if l + n > 8 * !Machine.config.Machine.sizeof_int then - acc,bcc,ml (* doesn't fit in current word *) - else - let t,e = type_to_dwarf m.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = Some !Machine.config.Machine.sizeof_int; - member_bit_offset = Some l; - member_bit_size = Some n; - member_data_member_location = None; - member_declaration = None; - member_name = if m.fld_name <> "" then Some m.fld_name else None; - member_type = t; - } in - pack ((new_entry (DW_TAG_member um))::acc) (e@bcc) (l + n) ms) - and translate acc bcc m = - match m with - [] -> acc,bcc - | m::ms as ml -> - (match m.fld_bitfield with - | None -> - let t,e = type_to_dwarf m.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = None; - member_bit_offset = None; - member_bit_size = None; - member_data_member_location = None; - member_declaration = None; - member_name = if m.fld_name <> "" then Some m.fld_name else None; - member_type = t; - } in - translate ((new_entry (DW_TAG_member um))::acc) (e@bcc) ms - | Some _ -> let acc,bcc,rest = pack acc bcc 0 ml in - translate acc bcc rest) - in - let children,e = translate [] [] m in - let children,e = List.rev children,e in - let sou = { - tag = tag; - children = children; - id = id;} in - e@[sou] - -(* Translate a union definition to its corresponding dwarf representation *) -let union_to_dwarf (n,at,m) env gloc = - let info = Env.find_union env n in - let tag = DW_TAG_union_type { - union_file_loc = Some gloc; - union_byte_size = info.ci_sizeof; - union_declaration = None; - union_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let children,e = mmap - (fun acc f -> - let t,e = type_to_dwarf f.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = None; - member_bit_offset = None; - member_bit_size = None; - member_data_member_location = None; - member_declaration = None; - member_name = if f.fld_name <> "" then Some f.fld_name else None; - member_type = t; - } in - new_entry (DW_TAG_member um),e@acc)[] m in - let sou = { - tag = tag; - children = children; - id = id;} in - e@[sou] - -(* Translate global declarations to there dwarf representation *) -let globdecl_to_dwarf env (typs,decls) decl = - PrintAsmaux.add_file (fst decl.gloc); - match decl.gdesc with - | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in - typs@ret,decls - | Gdecl d -> let t,d = glob_var_to_dwarf d decl.gloc in - typs@t,d::decls - | Gfundef f -> let t,d = fundef_to_dwarf f decl.gloc in - typs@t,d::decls - | Genumdef (n,at,e) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = enum_to_dwarf (n,at,e) decl.gloc in - typs@ret,decls - | Gcompositedef (Struct,n,at,m) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = struct_to_dwarf (n,at,m) env decl.gloc in - typs@ret,decls - | Gcompositedef (Union,n,at,m) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = union_to_dwarf (n,at,m) env decl.gloc in - typs@ret,decls - | Gcompositedecl (sou,i,_) -> Hashtbl.add composite_declarations i.stamp (sou,i.name,decl.gloc); - typs,decls - | Gpragma _ -> typs,decls - -let forward_declaration_to_dwarf sou name loc stamp = - let id = get_composite_type stamp in - let tag = match sou with - | Struct -> - DW_TAG_structure_type{ - structure_file_loc = Some loc; - structure_byte_size = None; - structure_declaration = Some true; - structure_name = if name <> "" then Some name else None; - } - | Union -> - DW_TAG_union_type { - union_file_loc = Some loc; - union_byte_size = None; - union_declaration = Some true; - union_name = if name <> "" then Some name else None; - } in - {tag = tag; children = []; id = id} - - -(* Compute the dwarf representations of global declarations. The second program argument is the - program after the bitfield and packed struct transformation *) -let program_to_dwarf prog prog1 name = - Hashtbl.reset type_table; - Hashtbl.reset composite_types_table; - Hashtbl.reset typedef_table; - let prog = cleanupGlobals (prog) in - let env = translEnv Env.empty prog1 in - reset_id (); - let typs = List.map (typedef_to_dwarf None) C2C.builtins.typedefs in - let typs = List.concat typs in - let typs,defs = List.fold_left (globdecl_to_dwarf env) (typs,[]) prog in - let typs = Hashtbl.fold (fun i (sou,name,loc) typs -> if not (IntSet.mem i !composite_defined) then - (forward_declaration_to_dwarf sou name loc i)::typs else typs) composite_declarations typs in - let defs = typs @ defs in - let cp = { - compile_unit_name = name; - } in - let cp = new_entry (DW_TAG_compile_unit cp) in - add_children cp defs diff --git a/debug/Debug.ml b/debug/Debug.ml new file mode 100644 index 00000000..161ee3ed --- /dev/null +++ b/debug/Debug.ml @@ -0,0 +1,123 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open BinNums +open C +open Camlcoq +open Dwarfgen +open DwarfTypes + +(* Interface for generating and printing debug information *) + +(* Record used for stroring references to the actual implementation functions *) +type implem = + { + mutable init: string -> unit; + mutable atom_function: ident -> atom -> unit; + mutable atom_global_variable: ident -> atom -> unit; + mutable set_composite_size: ident -> struct_or_union -> int option -> unit; + mutable set_member_offset: ident -> string -> int -> unit; + mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + mutable insert_global_declaration: Env.t -> globdecl -> unit; + mutable add_fun_addr: atom -> (int * int) -> unit; + mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; + mutable all_files_iter: (string -> unit) -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable atom_local_variable: ident -> atom -> unit; + mutable enter_scope: int -> int -> int -> unit; + mutable enter_function_scope: int -> int -> unit; + mutable add_lvar_scope: int -> ident -> int -> unit; + mutable open_scope: atom -> int -> positive -> unit; + mutable close_scope: atom -> int -> positive -> unit; + mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + mutable end_live_range: (atom * atom) -> positive -> unit; + mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + mutable function_end: atom -> positive -> unit; + mutable add_label: atom -> positive -> int -> unit; + mutable atom_parameter: ident -> ident -> atom -> unit; + mutable add_compilation_section_start: string -> int -> unit; + mutable add_compilation_section_end: string -> int -> unit; + mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + mutable compute_gnu_file_enum: (string -> unit) -> unit; + mutable exists_section: string -> bool; + mutable remove_unused: ident -> unit; + mutable variable_printed: string -> unit; + mutable add_diab_info: string -> (int * int * string) -> unit; + } + +let implem = + { + init = (fun _ -> ()); + atom_function = (fun _ _ -> ()); + atom_global_variable = (fun _ _ -> ()); + set_composite_size = (fun _ _ _ -> ()); + set_member_offset = (fun _ _ _ -> ()); + set_bitfield_offset = (fun _ _ _ _ _ -> ()); + insert_global_declaration = (fun _ _ -> ()); + add_fun_addr = (fun _ _ -> ()); + generate_debug_info = (fun _ _ -> None); + all_files_iter = (fun _ -> ()); + insert_local_declaration = (fun _ _ _ _ -> ()); + atom_local_variable = (fun _ _ -> ()); + enter_scope = (fun _ _ _ -> ()); + enter_function_scope = (fun _ _ -> ()); + add_lvar_scope = (fun _ _ _ -> ()); + open_scope = (fun _ _ _ -> ()); + close_scope = (fun _ _ _ -> ()); + start_live_range = (fun _ _ _ -> ()); + end_live_range = (fun _ _ -> ()); + stack_variable = (fun _ _ -> ()); + function_end = (fun _ _ -> ()); + add_label = (fun _ _ _ -> ()); + atom_parameter = (fun _ _ _ -> ()); + add_compilation_section_start = (fun _ _ -> ()); + add_compilation_section_end = (fun _ _ -> ()); + compute_diab_file_enum = (fun _ _ _ -> ()); + compute_gnu_file_enum = (fun _ -> ()); + exists_section = (fun _ -> true); + remove_unused = (fun _ -> ()); + variable_printed = (fun _ -> ()); + add_diab_info = (fun _ _ -> ()); +} + +let init_compile_unit name = implem.init name +let atom_function id atom = implem.atom_function id atom +let atom_global_variable id atom = implem.atom_global_variable id atom +let set_composite_size id sou size = implem.set_composite_size id sou size +let set_member_offset id field off = implem.set_member_offset id field off +let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size +let insert_global_declaration env dec = implem.insert_global_declaration env dec +let add_fun_addr atom addr = implem.add_fun_addr atom addr +let generate_debug_info fun_s var_s = implem.generate_debug_info fun_s var_s +let all_files_iter f = implem.all_files_iter f +let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc +let atom_local_variable id atom = implem.atom_local_variable id atom +let enter_scope p_id id = implem.enter_scope p_id id +let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id +let add_lvar_scope fun_id var_id s_id = implem.add_lvar_scope fun_id var_id s_id +let open_scope atom id lbl = implem.open_scope atom id lbl +let close_scope atom id lbl = implem.close_scope atom id lbl +let start_live_range atom lbl loc = implem.start_live_range atom lbl loc +let end_live_range atom lbl = implem.end_live_range atom lbl +let stack_variable atom loc = implem.stack_variable atom loc +let function_end atom loc = implem.function_end atom loc +let add_label atom p lbl = implem.add_label atom p lbl +let atom_parameter fid pid atom = implem.atom_parameter fid pid atom +let add_compilation_section_start sec addr = implem.add_compilation_section_start sec addr +let add_compilation_section_end sec addr = implem.add_compilation_section_end sec addr +let exists_section sec = implem.exists_section sec +let compute_diab_file_enum end_l entry_l line_e = implem.compute_diab_file_enum end_l entry_l line_e +let compute_gnu_file_enum f = implem.compute_gnu_file_enum f +let remove_unused ident = implem.remove_unused ident +let variable_printed ident = implem.variable_printed ident +let add_diab_info sec addr = implem.add_diab_info sec addr diff --git a/debug/Debug.mli b/debug/Debug.mli new file mode 100644 index 00000000..577b0ef8 --- /dev/null +++ b/debug/Debug.mli @@ -0,0 +1,88 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open C +open Camlcoq +open DwarfTypes +open BinNums + + +(* Record used for stroring references to the actual implementation functions *) +type implem = + { + mutable init: string -> unit; + mutable atom_function: ident -> atom -> unit; + mutable atom_global_variable: ident -> atom -> unit; + mutable set_composite_size: ident -> struct_or_union -> int option -> unit; + mutable set_member_offset: ident -> string -> int -> unit; + mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + mutable insert_global_declaration: Env.t -> globdecl -> unit; + mutable add_fun_addr: atom -> (int * int) -> unit; + mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; + mutable all_files_iter: (string -> unit) -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable atom_local_variable: ident -> atom -> unit; + mutable enter_scope: int -> int -> int -> unit; + mutable enter_function_scope: int -> int -> unit; + mutable add_lvar_scope: int -> ident -> int -> unit; + mutable open_scope: atom -> int -> positive -> unit; + mutable close_scope: atom -> int -> positive -> unit; + mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + mutable end_live_range: (atom * atom) -> positive -> unit; + mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + mutable function_end: atom -> positive -> unit; + mutable add_label: atom -> positive -> int -> unit; + mutable atom_parameter: ident -> ident -> atom -> unit; + mutable add_compilation_section_start: string -> int -> unit; + mutable add_compilation_section_end: string -> int -> unit; + mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + mutable compute_gnu_file_enum: (string -> unit) -> unit; + mutable exists_section: string -> bool; + mutable remove_unused: ident -> unit; + mutable variable_printed: string -> unit; + mutable add_diab_info: string -> (int * int * string) -> unit; + } + +val implem: implem + +val init_compile_unit: string -> unit +val atom_function: ident -> atom -> unit +val atom_global_variable: ident -> atom -> unit +val set_composite_size: ident -> struct_or_union -> int option -> unit +val set_member_offset: ident -> string -> int -> unit +val set_bitfield_offset: ident -> string -> int -> string -> int -> unit +val insert_global_declaration: Env.t -> globdecl -> unit +val add_fun_addr: atom -> (int * int) -> unit +val all_files_iter: (string -> unit) -> unit +val insert_local_declaration: storage -> ident -> typ -> location -> unit +val atom_local_variable: ident -> atom -> unit +val enter_scope: int -> int -> int -> unit +val enter_function_scope: int -> int -> unit +val add_lvar_scope: int -> ident -> int -> unit +val open_scope: atom -> int -> positive -> unit +val close_scope: atom -> int -> positive -> unit +val start_live_range: (atom * atom) -> positive -> (int * int builtin_arg) -> unit +val end_live_range: (atom * atom) -> positive -> unit +val stack_variable: (atom * atom) -> int * int builtin_arg -> unit +val function_end: atom -> positive -> unit +val add_label: atom -> positive -> int -> unit +val generate_debug_info: (atom -> string) -> string -> debug_entries option +val atom_parameter: ident -> ident -> atom -> unit +val add_compilation_section_start: string -> int -> unit +val add_compilation_section_end: string -> int -> unit +val compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit +val compute_gnu_file_enum: (string -> unit) -> unit +val exists_section: string -> bool +val remove_unused: ident -> unit +val variable_printed: string -> unit +val add_diab_info: string -> (int * int * string) -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml new file mode 100644 index 00000000..d1747f8e --- /dev/null +++ b/debug/DebugInformation.ml @@ -0,0 +1,704 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open BinNums +open C +open Camlcoq +open Cutil +open DebugTypes + +(* This implements an interface for the collection of debugging + information. *) + +(* Simple id generator *) +let id = ref 0 + +let next_id () = + let nid = !id in + incr id; nid + +let reset_id () = + id := 0 + +(* Auximilary functions *) +let list_replace c f l = + List.map (fun a -> if c a then f a else a) l + +(* The name of the current compilation unit *) +let file_name: string ref = ref "" + +(** All files used in the debug entries *) +module StringSet = Set.Make(String) +let all_files : StringSet.t ref = ref StringSet.empty +let add_file file = + all_files := StringSet.add file !all_files + +(* All types encountered *) +let types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 + +(* Lookup table for types *) +let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 + +(* Translate a C.typ to a string needed for hashing *) +let typ_to_string (ty: typ) = + let buf = Buffer.create 7 in + let chan = Format.formatter_of_buffer buf in + Cprint.print_debug_idents := true; + Cprint.typ chan ty; + Cprint.print_debug_idents := false; + Format.pp_print_flush chan (); + Buffer.contents buf + +(* Helper functions for the attributes *) +let strip_attributes typ = + let strip = List.filter (fun a -> a = AConst || a = AVolatile) in + match typ with + | TVoid at -> TVoid (strip at) + | TInt (k,at) -> TInt (k,strip at) + | TFloat (k,at) -> TFloat(k,strip at) + | TPtr (t,at) -> TPtr(t,strip at) + | TArray (t,s,at) -> TArray(t,s,strip at) + | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) + | TNamed (n,at) -> TNamed(n,strip at) + | TStruct (n,at) -> TStruct(n,strip at) + | TUnion (n,at) -> TUnion(n,strip at) + | TEnum (n,at) -> TEnum(n,strip at) + +let strip_last_attribute typ = + let rec hd_opt l = match l with + [] -> None,[] + | AConst::rest -> Some AConst,rest + | AVolatile::rest -> Some AVolatile,rest + | _::rest -> hd_opt rest in + match typ with + | TVoid at -> let l,r = hd_opt at in + l,TVoid r + | TInt (k,at) -> let l,r = hd_opt at in + l,TInt (k,r) + | TFloat (k,at) -> let l,r = hd_opt at in + l,TFloat (k,r) + | TPtr (t,at) -> let l,r = hd_opt at in + l,TPtr(t,r) + | TArray (t,s,at) -> let l,r = hd_opt at in + l,TArray(t,s,r) + | TFun (t,arg,v,at) -> let l,r = hd_opt at in + l,TFun(t,arg,v,r) + | TNamed (n,at) -> let l,r = hd_opt at in + l,TNamed(n,r) + | TStruct (n,at) -> let l,r = hd_opt at in + l,TStruct(n,r) + | TUnion (n,at) -> let l,r = hd_opt at in + l,TUnion(n,r) + | TEnum (n,at) -> let l,r = hd_opt at in + l,TEnum(n,r) + +(* Does the type already exist? *) +let exist_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + Hashtbl.mem lookup_types (typ_to_string ty) + +(* Find the type id to an type *) +let find_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + Hashtbl.find lookup_types (typ_to_string ty) + +(* Add type and information *) +let insert_type (ty: typ) = + let insert d_ty ty = + let id = next_id () + and name = typ_to_string ty in + Hashtbl.add types id d_ty; + Hashtbl.add lookup_types name id; + id in + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + let rec typ_aux ty = + try find_type ty with + | Not_found -> + let d_ty = + match ty with + | TVoid _ -> Void + | TInt (k,_) -> + IntegerType ({int_kind = k }) + | TFloat (k,_) -> + FloatType ({float_kind = k}) + | TPtr (t,_) -> + let id = attr_aux t in + PointerType ({pts = id}) + | TArray (t,s,_) -> + let rec size acc t = (match t with + | TArray (child,s,_) -> + size (s::acc) child + | _ -> t,List.rev acc) in + let t,s = size [s] t in + let id = attr_aux t in + let arr = { + arr_type = id; + arr_size= s; + } in + ArrayType arr + | TFun (t,param,va,_) -> + let param,prot = (match param with + | None -> [],false + | Some p -> List.map (fun (i,t) -> let t = attr_aux t in + { + param_type = t; + param_name = i.name; + }) p,true) in + let ret = (match t with + | TVoid _ -> None + | _ -> Some (attr_aux t)) in + let ftype = { + fun_return_type = ret; + fun_prototyped = prot; + fun_params = param; + } in + FunctionType ftype + | TNamed (id,_) -> + let typ = try + let _,t = + List.find (fun a -> fst a = id.name) CBuiltins.builtins.Builtins.typedefs in + Some (attr_aux t) + with Not_found -> None in + let t = { + typedef_file_loc = None; + typedef_name = id.name; + typ = typ; + } in + Typedef t + | TStruct (id,_) -> + let str = + { + ct_name = id.name; + ct_sou = Struct; + ct_file_loc = None; + ct_members = []; + ct_declaration = true; + ct_sizeof = None; + } in + CompositeType str + | TUnion (id,_) -> + let union = + { + ct_name = id.name; + ct_sou = Union; + ct_file_loc = None; + ct_members = []; + ct_declaration = true; + ct_sizeof = None; + } in + CompositeType union + | TEnum (id,_) -> + let enum = + { + enum_name = id.name; + enum_byte_size = None; + enum_file_loc = None; + enum_enumerators = []; + } in + EnumType enum in + insert d_ty ty + and attr_aux ty = + try + find_type ty + with + Not_found -> + match strip_last_attribute ty with + | Some AConst,t -> + let id = attr_aux t in + let const = { cst_type = id} in + insert (ConstType const) ty + | Some AVolatile,t -> + let id = attr_aux t in + let volatile = {vol_type = id} in + insert (VolatileType volatile) ty + | Some (ARestrict|AAlignas _| Attr(_,_)),t -> + attr_aux t + | None,t -> typ_aux t + in + attr_aux ty + +(* Replace the composite information *) +let replace_composite id f = + let str = Hashtbl.find types id in + match str with + | CompositeType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace types id (CompositeType comp') + | _ -> assert false (* This should never happen *) + +(* Replace the enum information *) +let replace_enum id f = + let str = Hashtbl.find types id in + match str with + | EnumType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace types id (EnumType comp') + | _ -> assert false (* This should never happen *) + +(* Replace the typdef information *) +let replace_typedef id f = + let typdef = Hashtbl.find types id in + match typdef with + | Typedef typ -> let typ' = f typ in + if typ <> typ' then Hashtbl.replace types id (Typedef typ') + | _ -> assert false (* This should never happen *) + + +(* All global definitions encountered *) +let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from stamp to debug id *) +let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from name to debug id *) +let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from atom to debug id *) +let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 + +let find_gvar_stamp id = + let id = (Hashtbl.find stamp_to_definition id) in + let var = Hashtbl.find definitions id in + match var with + | GlobalVariable var -> id,var + | _ -> assert false + +let find_fun_stamp id = + let id = (Hashtbl.find stamp_to_definition id) in + let f = Hashtbl.find definitions id in + match f with + | Function f -> id,f + | _ -> assert false + +let find_fun_atom id = + let id = (Hashtbl.find atom_to_definition id) in + let f = Hashtbl.find definitions id in + match f with + | Function f -> id,f + | _ -> assert false + +let replace_var id var = + let var = GlobalVariable var in + Hashtbl.replace definitions id var + +let replace_fun id f = + let f = Function f in + Hashtbl.replace definitions id f + +(* All local variables *) +let local_variables: (int, local_information) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from stampt to the debug id of the local variable *) +let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 + +(* Mapping form atom to the debug id of the local variable *) +let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 + +(* Map from scope id + function id to debug id *) +let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 + +(* Map from scope id + function atom to debug id *) +let atom_to_scope: (atom * int, int) Hashtbl.t = Hashtbl.create 7 + +let find_lvar_stamp id = + let id = (Hashtbl.find stamp_to_local id) in + let v = Hashtbl.find local_variables id in + match v with + | LocalVariable v -> id,v + | _ -> assert false + +let replace_lvar id var = + let var = LocalVariable var in + Hashtbl.replace local_variables id var + +let find_scope_id fid id = + let id = Hashtbl.find scope_to_local (fid,id) in + let v = Hashtbl.find local_variables id in + match v with + | Scope v -> id,v + | _ -> assert false + +let replace_scope id var = + let var = Scope var in + Hashtbl.replace local_variables id var + +let gen_comp_typ sou id at = + if sou = Struct then + TStruct (id,at) + else + TUnion (id,at) + +let remove_unused id = + try + let id' = Hashtbl.find stamp_to_definition id.stamp in + Hashtbl.remove definitions id'; + Hashtbl.remove stamp_to_definition id.stamp + with Not_found -> () + +let insert_global_declaration env dec= + add_file (fst dec.gloc); + let insert d_dec stamp = + let id = next_id () in + Hashtbl.add definitions id d_dec; + Hashtbl.add stamp_to_definition stamp id + in + match dec.gdesc with + | Gdecl (sto,id,ty,init) -> + if not (is_function_type env ty) then begin + if not (Hashtbl.mem stamp_to_definition id.stamp) then begin + let at_decl,ext = (match sto with + | Storage_extern -> init = None,true + | Storage_static -> false,false + | _ -> false,true) in + let ty = insert_type ty in + let decl = { + gvar_name = id.name; + gvar_atom = None; + gvar_file_loc = dec.gloc; + gvar_declaration = at_decl; + gvar_external = ext; + gvar_type = ty; + } in + insert (GlobalVariable decl) id.stamp + end else if init <> None || sto <> Storage_extern then begin (* It is a definition *) + let id,var = find_gvar_stamp id.stamp in + replace_var id ({var with gvar_declaration = false;}) + end + end else begin + (* Implict declarations need special handling *) + let id' = try Hashtbl.find name_to_definition id.name with Not_found -> + let id' = next_id () in + Hashtbl.add name_to_definition id.name id';id' in + Hashtbl.add stamp_to_definition id.stamp id' + end + | Gfundef f -> + let ret = (match f.fd_ret with + | TVoid _ -> None + | _ -> Some (insert_type f.fd_ret)) in + let ext = (match f.fd_storage with + | Storage_static -> false + | _ -> true) in + let params = List.map (fun (p,ty) -> + let ty = insert_type ty in + { + parameter_name = p.name; + parameter_ident = p.stamp; + parameter_atom = None; + parameter_type = ty; + }) f.fd_params in + let fd = + { + fun_name = f.fd_name.name; + fun_atom = None; + fun_file_loc = dec.gloc; + fun_external = ext; + fun_return_type = ret; + fun_vararg = f.fd_vararg; + fun_parameter = params; + fun_low_pc = None; + fun_high_pc = None; + fun_scope = None; + } in + begin + let id' = try Hashtbl.find name_to_definition f.fd_name.name with Not_found -> + let id' = next_id () in + Hashtbl.add name_to_definition f.fd_name.name id';id' in + Hashtbl.add stamp_to_definition f.fd_name.stamp id'; + Hashtbl.add definitions id' (Function fd) + end + | Gcompositedecl (sou,id,at) -> + ignore (insert_type (gen_comp_typ sou id at)); + let id = find_type (gen_comp_typ sou id []) in + replace_composite id (fun comp -> if comp.ct_file_loc = None then + {comp with ct_file_loc = Some (dec.gloc);} + else comp) + | Gcompositedef (sou,id,at,fi) -> + ignore (insert_type (gen_comp_typ sou id at)); + let id = find_type (gen_comp_typ sou id []) in + let fi = List.filter (fun f -> f.fld_name <> "") fi in (* Fields without names need no info *) + let fields = List.map (fun f -> + { + cfd_name = f.fld_name; + cfd_typ = insert_type f.fld_typ; + cfd_bit_size = f.fld_bitfield; + cfd_bit_offset = None; + cfd_byte_offset = None; + cfd_byte_size = None; + cfd_bitfield = None; + }) fi in + replace_composite id (fun comp -> + let loc = if comp.ct_file_loc = None then Some dec.gloc else comp.ct_file_loc in + {comp with ct_file_loc = loc; ct_members = fields; ct_declaration = false;}) + | Gtypedef (id,t) -> + let id = insert_type (TNamed (id,[])) in + let tid = insert_type t in + replace_typedef id (fun typ -> {typ with typedef_file_loc = Some dec.gloc; typ = Some tid;}); + | Genumdef (n,at,e) -> + ignore(insert_type (TEnum (n,at))); + let id = find_type (TEnum (n,[])) in + let enumerator = List.map (fun (i,c,_) -> + { + enumerator_name = i.name; + enumerator_const = c; + }) e in + replace_enum id (fun en -> + {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) + | Gpragma _ -> () + +let set_member_offset str field offset = + let id = find_type (TStruct (str,[])) in + replace_composite id (fun comp -> + let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in + let members = list_replace name (fun a -> {a with cfd_byte_offset = Some offset;}) comp.ct_members in + {comp with ct_members = members;}) + +let set_composite_size comp sou size = + let id = find_type (gen_comp_typ sou comp []) in + replace_composite id (fun comp -> {comp with ct_sizeof = size;}) + +let set_bitfield_offset str field offset underlying size = + let id = find_type (TStruct (str,[])) in + replace_composite id (fun comp -> + let name f = f.cfd_name = field in + let members = list_replace name (fun a -> + {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size}) + comp.ct_members in + {comp with ct_members = members;}) + +let atom_global_variable id atom = + try + let id,var = find_gvar_stamp id.stamp in + replace_var id ({var with gvar_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id + with Not_found -> () + +let atom_function id atom = + try + let id',f = find_fun_stamp id.stamp in + replace_fun id' ({f with fun_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id'; + Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then + Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local + with Not_found -> () + +let atom_parameter fid id atom = + try + let fid',f = find_fun_stamp fid.stamp in + let name p = p.parameter_ident = id.stamp in + let params = list_replace name (fun p -> {p with parameter_atom = Some atom;}) f.fun_parameter in + replace_fun fid' ({f with fun_parameter = params;}) + with Not_found -> () + +let add_fun_addr atom (high,low) = + try + let id,f = find_fun_atom atom in + replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + with Not_found -> () + +let atom_local_variable id atom = + try + let id,var = find_lvar_stamp id.stamp in + replace_lvar id ({var with lvar_atom = Some atom;}); + Hashtbl.add atom_to_local atom id + with Not_found -> () + +let add_lvar_scope f_id var_id s_id = + try + let s_id',scope = find_scope_id f_id s_id in + let var_id,_ = find_lvar_stamp var_id.stamp in + replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;}) + with Not_found -> () + +let insert_local_declaration sto id ty loc = + add_file (fst loc); + let ty = insert_type ty in + let var = { + lvar_name = id.name; + lvar_atom = None; + lvar_file_loc = loc; + lvar_type = ty; + lvar_static = sto = Storage_static; + } in + let id' = next_id () in + Hashtbl.add local_variables id' (LocalVariable var); + Hashtbl.add stamp_to_local id.stamp id' + +let new_scope f_id sc_id = + let scope = {scope_variables = [];} in + let id = next_id () in + Hashtbl.add local_variables id (Scope scope); + Hashtbl.add scope_to_local (f_id,sc_id) id; + id + +let enter_function_scope fun_id sc_id = + try + let id = new_scope fun_id sc_id in + let fun_id,f = find_fun_stamp fun_id in + replace_fun fun_id ({f with fun_scope = Some id}) + with Not_found -> () + +let enter_scope f_id p_id id = + try + let id' = new_scope f_id id in + let p_id',scope = find_scope_id f_id p_id in + replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) + with Not_found -> () + + +type scope_range = + { + start_addr: positive option; + end_addr: positive option; + } + +type var_range = + { + range_start: positive option; + range_end: positive option; + var_loc: int * int builtin_arg; + } + +type var_location = + | RangeLoc of var_range list + | FunctionLoc of int * int builtin_arg (* Stack allocated variables *) + +let var_locations: (atom * atom,var_location) Hashtbl.t = Hashtbl.create 7 + +let scope_ranges: (int,scope_range list) Hashtbl.t = Hashtbl.create 7 + +let label_translation: (atom * positive, int) Hashtbl.t = Hashtbl.create 7 + +let add_label atom p i = + Hashtbl.add label_translation (atom,p) i + +(* Auxiliary data structures and functions *) +module IntSet = Set.Make(struct + type t = int + let compare (x:int) (y:int) = compare x y +end) + +let open_scopes: IntSet.t ref = ref IntSet.empty +let open_vars: atom list ref = ref [] + +let open_scope atom s_id lbl = + try + let s_id = Hashtbl.find atom_to_scope (atom,s_id) in + let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in + let n_scop = { start_addr = Some lbl; end_addr = None;} in + open_scopes := IntSet.add s_id !open_scopes; + Hashtbl.replace scope_ranges s_id (n_scop::old_r) + with Not_found -> () + +let close_scope atom s_id lbl = + try + let s_id = Hashtbl.find atom_to_scope (atom,s_id) in + let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in + let last_r,rest = + begin + match old_r with + | a::rest -> a,rest + | _ -> assert false (* We must have an opening scope *) + end in + let new_r = ({last_r with end_addr = Some lbl;})::rest in + open_scopes := IntSet.remove s_id !open_scopes; + Hashtbl.replace scope_ranges s_id new_r + with Not_found -> () + +let start_live_range (f,v) lbl loc = + let old_r = begin try Hashtbl.find var_locations (f,v) with Not_found -> (RangeLoc []) end in + match old_r with + | RangeLoc old_r -> + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + open_vars := v::!open_vars; + Hashtbl.replace var_locations (f,v) (RangeLoc (n_r::old_r)) + | _ -> () (* Parameter that is passed as variable *) + +let end_live_range (f,v) lbl = + try + let old_r = Hashtbl.find var_locations (f,v) in + match old_r with + | RangeLoc (n_r::old_r) -> + if n_r.range_end = None then (* We can skip non open locations *) + let n_r = {n_r with range_end = Some lbl} in + Hashtbl.replace var_locations (f,v) (RangeLoc (n_r::old_r)) + | _ -> () + with Not_found -> () + +let stack_variable (f,v) (sp,loc) = + Hashtbl.add var_locations (f,v) (FunctionLoc (sp,loc)) + +let function_end atom loc = + IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; + open_scopes := IntSet.empty; + List.iter (fun id-> end_live_range (atom,id) loc) !open_vars; + open_vars:= [] + +let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 +let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 + +let diab_additional: (string,int * int * string) Hashtbl.t = Hashtbl.create 7 + +let add_compilation_section_start sec addr = + Hashtbl.add compilation_section_start sec addr + +let add_compilation_section_end sec addr = + Hashtbl.add compilation_section_end sec addr + +let add_diab_info sec addr = + Hashtbl.add diab_additional sec addr + +let exists_section sec = + Hashtbl.mem compilation_section_start sec + +let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7 + +let compute_diab_file_enum end_label entry_label line_end = + Hashtbl.iter (fun sec (_,_,secname) -> + Hashtbl.add compilation_section_end sec (end_label secname); + StringSet.iter (fun file -> + let lbl = entry_label file in + Hashtbl.add filenum (sec,file) lbl) !all_files; + line_end ()) diab_additional + +let compute_gnu_file_enum f = + StringSet.iter f !all_files + +let printed_vars: StringSet.t ref = ref StringSet.empty + +let variable_printed id = + printed_vars := StringSet.add id !printed_vars + +let init name = + id := 0; + file_name := name; + Hashtbl.reset types; + Hashtbl.reset lookup_types; + Hashtbl.reset definitions; + Hashtbl.reset stamp_to_definition; + Hashtbl.reset name_to_definition; + Hashtbl.reset atom_to_definition; + Hashtbl.reset local_variables; + Hashtbl.reset stamp_to_local; + Hashtbl.reset atom_to_local; + Hashtbl.reset scope_to_local; + Hashtbl.reset atom_to_scope; + Hashtbl.reset compilation_section_start; + Hashtbl.reset compilation_section_end; + Hashtbl.reset diab_additional; + Hashtbl.reset filenum; + Hashtbl.reset var_locations; + Hashtbl.reset scope_ranges; + Hashtbl.reset label_translation; + all_files := StringSet.singleton name; + printed_vars := StringSet.empty; diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml new file mode 100644 index 00000000..7ee56ff1 --- /dev/null +++ b/debug/DebugInit.ml @@ -0,0 +1,95 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open BinNums +open C +open Camlcoq +open Dwarfgen +open DwarfTypes +open Debug + +let init_debug () = + implem.init <- DebugInformation.init; + implem.atom_function <- DebugInformation.atom_function; + implem.atom_global_variable <- DebugInformation.atom_global_variable; + implem.set_composite_size <- DebugInformation.set_composite_size; + implem.set_member_offset <- DebugInformation.set_member_offset; + implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; + implem.insert_global_declaration <- DebugInformation.insert_global_declaration; + implem.add_fun_addr <- DebugInformation.add_fun_addr; + implem.generate_debug_info <- + if Configuration.system = "diab" then + (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) + else + (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)); + implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); + implem.insert_local_declaration <- DebugInformation.insert_local_declaration; + implem.atom_local_variable <- DebugInformation.atom_local_variable; + implem.enter_scope <- DebugInformation.enter_scope; + implem.enter_function_scope <- DebugInformation.enter_function_scope; + implem.add_lvar_scope <- DebugInformation.add_lvar_scope; + implem.open_scope <- DebugInformation.open_scope; + implem.close_scope <- DebugInformation.close_scope; + implem.start_live_range <- DebugInformation.start_live_range; + implem.end_live_range <- DebugInformation.end_live_range; + implem.stack_variable <- DebugInformation.stack_variable; + implem.function_end <- DebugInformation.function_end; + implem.add_label <- DebugInformation.add_label; + implem.atom_parameter <- DebugInformation.atom_parameter; + implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start; + implem.add_compilation_section_end <- DebugInformation.add_compilation_section_end; + implem.compute_diab_file_enum <- DebugInformation.compute_diab_file_enum; + implem.compute_gnu_file_enum <- DebugInformation.compute_gnu_file_enum; + implem.exists_section <- DebugInformation.exists_section; + implem.remove_unused <- DebugInformation.remove_unused; + implem.variable_printed <- DebugInformation.variable_printed; + implem.add_diab_info <- DebugInformation.add_diab_info + +let init_none () = + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (fun _ _ -> ()); + implem.set_composite_size <- (fun _ _ _ -> ()); + implem.set_member_offset <- (fun _ _ _ -> ()); + implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); + implem.insert_global_declaration <- (fun _ _ -> ()); + implem.add_fun_addr <- (fun _ _ -> ()); + implem.generate_debug_info <- (fun _ _ -> None); + implem.all_files_iter <- (fun _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ -> ()); + implem.atom_local_variable <- (fun _ _ -> ()); + implem.enter_scope <- (fun _ _ _ -> ()); + implem.enter_function_scope <- (fun _ _ -> ()); + implem.add_lvar_scope <- (fun _ _ _ -> ()); + implem.open_scope <- (fun _ _ _ -> ()); + implem.close_scope <- (fun _ _ _ -> ()); + implem.start_live_range <- (fun _ _ _ -> ()); + implem.end_live_range <- (fun _ _ -> ()); + implem.stack_variable <- (fun _ _ -> ()); + implem.function_end <- (fun _ _ -> ()); + implem.add_label <- (fun _ _ _ -> ()); + implem.atom_parameter <- (fun _ _ _ -> ()); + implem.add_compilation_section_start <- (fun _ _ -> ()); + implem.add_compilation_section_end <- (fun _ _ -> ()); + implem.compute_diab_file_enum <- (fun _ _ _ -> ()); + implem.compute_gnu_file_enum <- (fun _ -> ()); + implem.exists_section <- (fun _ -> true); + implem.remove_unused <- (fun _ -> ()); + implem.variable_printed <- (fun _ -> ()); + implem.add_diab_info <- (fun _ _ -> ()) + +let init () = + if !Clflags.option_g && Configuration.advanced_debug then + init_debug () + else + init_none () diff --git a/debug/DebugTypes.mli b/debug/DebugTypes.mli new file mode 100644 index 00000000..6a4f619c --- /dev/null +++ b/debug/DebugTypes.mli @@ -0,0 +1,160 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Camlcoq + +(* Types for the information of type info *) +type composite_field = + { + cfd_name: string; + cfd_typ: int; + cfd_bit_size: int option; + cfd_bit_offset: int option; + cfd_byte_offset: int option; + cfd_byte_size: int option; + cfd_bitfield: string option; + } + +type composite_type = + { + ct_name: string; + ct_sou: struct_or_union; + ct_file_loc: location option; + ct_members: composite_field list; + ct_sizeof: int option; + ct_declaration: bool; + } + +type ptr_type = { + pts: int + } + +type const_type = { + cst_type: int + } + +type volatile_type = { + vol_type: int + } + + +type array_type = { + arr_type: int; + arr_size: int64 option list; + } + +type typedef = { + typedef_file_loc: location option; + typedef_name: string; + typ: int option; + } + +type enumerator = { + enumerator_name: string; + enumerator_const: int64; + } + +type enum_type = { + enum_name: string; + enum_byte_size: int option; + enum_file_loc: location option; + enum_enumerators: enumerator list; + } + +type int_type = { + int_kind: ikind; + } + +type float_type = { + float_kind: fkind; + } + +type parameter_type = { + param_type: int; + param_name: string; + } + +type function_type = { + fun_return_type: int option; + fun_prototyped: bool; + fun_params: parameter_type list; + } + +type debug_types = + | IntegerType of int_type + | FloatType of float_type + | PointerType of ptr_type + | ArrayType of array_type + | CompositeType of composite_type + | EnumType of enum_type + | FunctionType of function_type + | Typedef of typedef + | ConstType of const_type + | VolatileType of volatile_type + | Void + +(* Types for global definitions *) + +(* Information for a global variable *) +type global_variable_information = { + gvar_name: string; + gvar_atom: atom option; + gvar_file_loc: location; + gvar_declaration: bool; + gvar_external: bool; + gvar_type: int; + } + +type parameter_information = + { + parameter_name: string; + parameter_ident: int; + parameter_atom: atom option; + parameter_type: int; +} + +type function_information = { + fun_name: string; + fun_atom: atom option; + fun_file_loc: location; + fun_external: bool; + fun_return_type: int option; (* Again the special case of void functions *) + fun_vararg: bool; + fun_parameter: parameter_information list; + fun_low_pc: int option; + fun_high_pc: int option; + fun_scope: int option; + } + +type definition_type = + | GlobalVariable of global_variable_information + | Function of function_information + + +(* Information for local variables *) +type local_variable_information = { + lvar_name: string; + lvar_atom: atom option; + lvar_file_loc:location; + lvar_type: int; + lvar_static: bool; (* Static variable are mapped to symbols *) + } + +type scope_information = + { + scope_variables: int list; (* Variable and Scope ids *) + } + +type local_information = + | LocalVariable of local_variable_information + | Scope of scope_information diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 15843eb9..1bd54470 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -19,14 +19,13 @@ open PrintAsmaux open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) -module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): +module DwarfPrinter(Target: DWARF_TARGET): sig - val print_debug: out_channel -> dw_entry -> unit + val print_debug: out_channel -> debug_entries -> unit end = struct open Target - open DwarfAbbrevs (* Byte value to string *) let string_of_byte value = @@ -36,6 +35,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_label oc lbl = fprintf oc "%a:\n" label lbl + (* Print a positive label *) + let print_plabel oc lbl = + print_label oc (transl_label lbl) + (* Helper functions for abbreviation printing *) let add_byte buf value = Buffer.add_string buf (string_of_byte value) @@ -64,18 +67,15 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) - let add_fun_pc sp buf = - match get_fun_addr sp.subprogram_name with - | None ->() - | Some (a,b) -> add_high_pc buf; add_low_pc buf - let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) let add_location loc buf = match loc with | None -> () - | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf - | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf + | Some (LocList _ ) + | Some (LocSymbol _) + | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = @@ -105,8 +105,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_TAG_compile_unit e -> prologue 0x11; add_abbr_entry (0x1b,comp_dir_type_abbr) buf; - add_high_pc buf; add_low_pc buf; + add_high_pc buf; add_abbr_entry (0x13,language_type_abbr) buf; add_name buf; add_abbr_entry (0x25,producer_type_abbr) buf; @@ -129,32 +129,31 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0x5; add_attr_some e.formal_parameter_file_loc add_file_loc; add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); - add_location e.formal_parameter_location buf; add_attr_some e.formal_parameter_name add_name; - add_location e.formal_parameter_segment buf; add_type buf; - add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) + add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)); + add_location e.formal_parameter_location buf | DW_TAG_label _ -> prologue 0xa; add_low_pc buf; add_name buf; - | DW_TAG_lexical_block _ -> + | DW_TAG_lexical_block a -> prologue 0xb; - add_high_pc buf; - add_low_pc buf + add_attr_some a.lexical_block_high_pc add_high_pc; + add_attr_some a.lexical_block_low_pc add_low_pc | DW_TAG_member e -> prologue 0xd; add_attr_some e.member_file_loc add_file_loc; - add_attr_some e.member_byte_size add_member_size; - add_attr_some e.member_bit_offset (add_abbr_entry (0xd,bit_offset_type_abbr)); - add_attr_some e.member_bit_size (add_abbr_entry (0xc,bit_size_type_abbr)); + add_attr_some e.member_byte_size add_byte_size; + add_attr_some e.member_bit_offset (add_abbr_entry (0xc,bit_offset_type_abbr)); + add_attr_some e.member_bit_size (add_abbr_entry (0xd,bit_size_type_abbr)); + add_attr_some e.member_declaration add_declaration; + add_attr_some e.member_name add_name; + add_type buf; (match e.member_data_member_location with | None -> () | Some (DataLocBlock __) -> add_abbr_entry (0x38,data_location_block_type_abbr) buf - | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf); - add_attr_some e.member_declaration add_declaration; - add_attr_some e.member_name add_name; - add_type buf + | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf) | DW_TAG_pointer_type _ -> prologue 0xf; add_type buf @@ -166,9 +165,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.structure_name add_name | DW_TAG_subprogram e -> prologue 0x2e; - add_attr_some e.subprogram_file_loc add_file_loc; + add_file_loc buf; add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); - add_fun_pc e buf; + add_attr_some e.subprogram_high_pc add_high_pc; + add_attr_some e.subprogram_low_pc add_low_pc; add_name buf; add_abbr_entry (0x27,prototyped_type_abbr) buf; add_attr_some e.subprogram_type add_type; @@ -200,12 +200,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) | DW_TAG_variable e -> prologue 0x34; - add_attr_some e.variable_file_loc add_file_loc; + add_file_loc buf; add_attr_some e.variable_declaration add_declaration; add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); add_location e.variable_location buf; add_name buf; - add_location e.variable_segment buf; add_type buf | DW_TAG_volatile_type _ -> prologue 0x35; @@ -246,10 +245,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_abbrev oc = let abbrevs = Hashtbl.fold (fun s i acc -> (s,i)::acc) abbrev_mapping [] in let abbrevs = List.sort (fun (_,a) (_,b) -> Pervasives.compare a b) abbrevs in - fprintf oc " .section %s\n" (name_of_section Section_debug_abbrev); - let lbl = new_label () in - abbrev_start_addr := lbl; - print_label oc lbl; + section oc Section_debug_abbrev; + print_label oc !abbrev_start_addr; List.iter (fun (s,id) -> fprintf oc " .uleb128 %d\n" id; output_string oc s; @@ -259,6 +256,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let debug_start_addr = ref (-1) + let debug_stmt_list = ref (-1) + let entry_labels: (int,int) Hashtbl.t = Hashtbl.create 7 (* Translate the ids to address labels *) @@ -270,15 +269,28 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): Hashtbl.add entry_labels id label; label + let loc_labels: (int,int) Hashtbl.t = Hashtbl.create 7 + + (* Translate the ids to address labels *) + let loc_to_label id = + try + Hashtbl.find loc_labels id + with Not_found -> + let label = new_label () in + Hashtbl.add loc_labels id label; + label + + let print_loc_ref oc r = + let ref = loc_to_label r in + fprintf oc " .4byte %a\n" label ref + + (* Helper functions for debug printing *) let print_opt_value oc o f = match o with | None -> () | Some o -> f oc o - let print_file_loc oc f = - print_opt_value oc f print_file_loc - let print_flag oc b = output_string oc (string_of_byte b) @@ -294,16 +306,77 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_byte oc b = fprintf oc " .byte 0x%X\n" b - let print_loc oc loc = - () - - let print_data_location oc dl = - () + let print_2byte oc b = + fprintf oc " .2byte 0x%X\n" b let print_ref oc r = let ref = entry_to_label r in fprintf oc " .4byte %a\n" label ref + let print_file_loc oc = function + | Some (Diab_file_loc (file,col)) -> + fprintf oc " .4byte %a\n" label file; + print_uleb128 oc col + | Some (Gnu_file_loc (file,col)) -> + fprintf oc " .4byte %l\n" file; + print_uleb128 oc col + | None -> () + + let print_loc_expr oc = function + | DW_OP_bregx (a,b) -> + print_byte oc dw_op_bregx; + print_uleb128 oc a; + fprintf oc " .sleb128 %ld\n" b + | DW_OP_plus_uconst i -> + print_byte oc dw_op_plus_uconst; + print_uleb128 oc i + | DW_OP_piece i -> + print_byte oc dw_op_piece; + print_uleb128 oc i + | DW_OP_reg i -> + if i < 32 then + print_byte oc (dw_op_reg0 + i) + else begin + print_byte oc dw_op_regx; + print_uleb128 oc i + end + + let print_loc oc loc = + match loc with + | LocSymbol s -> + print_sleb128 oc 5; + print_byte oc dw_op_addr; + fprintf oc " .4byte %a\n" symbol s + | LocSimple e -> + print_sleb128 oc (size_of_loc_expr e); + print_loc_expr oc e + | LocList e -> + let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in + print_sleb128 oc size; + List.iter (print_loc_expr oc) e + | LocRef f -> print_loc_ref oc f + + let print_list_loc oc = function + | LocSymbol s -> + print_2byte oc 5; + print_byte oc dw_op_addr; + fprintf oc " .4byte %a\n" symbol s + | LocSimple e -> + print_2byte oc (size_of_loc_expr e); + print_loc_expr oc e + | LocList e -> + let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in + print_2byte oc size; + List.iter (print_loc_expr oc) e + | LocRef f -> print_loc_ref oc f + + let print_data_location oc dl = + match dl with + | DataLocBlock e -> + print_sleb128 oc (size_of_loc_expr e); + print_loc_expr oc e + | _ -> () + let print_addr oc a = fprintf oc " .4byte %a\n" label a @@ -334,14 +407,20 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_string oc bt.base_type_name let print_compilation_unit oc tag = - let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:%s" Version.version Configuration.arch in + let version_string = + if Version.buildnr <> "" && Version.tag <> "" then + sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + else + Version.version in + let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" + version_string Configuration.arch Configuration.system Configuration.abi Configuration.model in print_string oc (Sys.getcwd ()); - print_addr oc (get_end_addr ()); - print_addr oc (get_start_addr ()); + print_addr oc tag.compile_unit_low_pc; + print_addr oc tag.compile_unit_high_pc; print_uleb128 oc 1; print_string oc tag.compile_unit_name; print_string oc prod_name; - print_addr oc (get_stmt_list_addr ()) + print_addr oc !debug_stmt_list let print_const_type oc ct = print_ref oc ct.const_type @@ -360,29 +439,30 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_formal_parameter oc fp = print_file_loc oc fp.formal_parameter_file_loc; print_opt_value oc fp.formal_parameter_artificial print_flag; - print_opt_value oc fp.formal_parameter_location print_loc; print_opt_value oc fp.formal_parameter_name print_string; - print_opt_value oc fp.formal_parameter_segment print_loc; print_ref oc fp.formal_parameter_type; - print_opt_value oc fp.formal_parameter_variable_parameter print_flag + print_opt_value oc fp.formal_parameter_variable_parameter print_flag; + print_opt_value oc fp.formal_parameter_location print_loc let print_tag_label oc tl = print_ref oc tl.label_low_pc; print_string oc tl.label_name + let print_lexical_block oc lb = - print_ref oc lb.lexical_block_high_pc; - print_ref oc lb.lexical_block_low_pc + print_opt_value oc lb.lexical_block_high_pc print_addr; + print_opt_value oc lb.lexical_block_low_pc print_addr let print_member oc mb = print_file_loc oc mb.member_file_loc; print_opt_value oc mb.member_byte_size print_byte; print_opt_value oc mb.member_bit_offset print_byte; print_opt_value oc mb.member_bit_size print_byte; - print_opt_value oc mb.member_data_member_location print_data_location; print_opt_value oc mb.member_declaration print_flag; print_opt_value oc mb.member_name print_string; - print_ref oc mb.member_type + print_ref oc mb.member_type; + print_opt_value oc mb.member_data_member_location print_data_location + let print_pointer oc pt = print_ref oc pt.pointer_type @@ -398,11 +478,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): fprintf oc " .4byte %a\n" label s let print_subprogram oc sp = - let addr = get_fun_addr sp.subprogram_name in - print_file_loc oc sp.subprogram_file_loc; + print_file_loc oc (Some sp.subprogram_file_loc); print_opt_value oc sp.subprogram_external print_flag; - print_opt_value oc sp.subprogram_frame_base print_loc; - print_opt_value oc addr print_subprogram_addr; + print_opt_value oc sp.subprogram_high_pc print_addr; + print_opt_value oc sp.subprogram_low_pc print_addr; print_string oc sp.subprogram_name; print_flag oc sp.subprogram_prototyped; print_opt_value oc sp.subprogram_type print_ref @@ -431,12 +510,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc up.unspecified_parameter_artificial print_flag let print_variable oc var = - print_file_loc oc var.variable_file_loc; + print_file_loc oc (Some var.variable_file_loc); print_opt_value oc var.variable_declaration print_flag; print_opt_value oc var.variable_external print_flag; print_opt_value oc var.variable_location print_loc; print_string oc var.variable_name; - print_opt_value oc var.variable_segment print_loc; print_ref oc var.variable_type let print_volatile_type oc vt = @@ -482,16 +560,16 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_sleb128 oc 0) entry (* Print the debug abbrev section *) - let print_debug_abbrev oc entry = - compute_abbrev entry; + let print_debug_abbrev oc entries = + List.iter (fun (_,_,_,e,_) -> compute_abbrev e) entries; print_abbrev oc (* Print the debug info section *) - let print_debug_info oc entry = - let debug_start = new_label () in - debug_start_addr:= debug_start; - fprintf oc" .section %s\n" (name_of_section Section_debug_info); - print_label oc debug_start; + let print_debug_info oc start line_start entry = + Hashtbl.reset entry_labels; + debug_start_addr:= start; + debug_stmt_list:= line_start; + print_label oc start; let debug_length_start = new_label () (* Address used for length calculation *) and debug_end = new_label () in fprintf oc " .4byte %a-%a\n" label debug_end label debug_length_start; @@ -503,10 +581,58 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_sleb128 oc 0; print_label oc debug_end (* End of the debug section *) + let print_location_entry oc c_low l = + print_label oc (loc_to_label l.loc_id); + List.iter (fun (b,e,loc) -> + fprintf oc " .4byte %a-%a\n" label b label c_low; + fprintf oc " .4byte %a-%a\n" label e label c_low; + print_list_loc oc loc) l.loc; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n" + + let print_location_entry_abs oc l = + print_label oc (loc_to_label l.loc_id); + List.iter (fun (b,e,loc) -> + fprintf oc " .4byte %a\n" label b; + fprintf oc " .4byte %a\n" label e; + print_list_loc oc loc) l.loc; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n" + + + let print_location_list oc (c_low,l) = + let f = match c_low with + | Some s -> print_location_entry oc s + | None -> print_location_entry_abs oc in + List.iter f l + + let print_diab_entries oc entries = + let abbrev_start = new_label () in + abbrev_start_addr := abbrev_start; + print_debug_abbrev oc entries; + List.iter (fun (s,d,l,e,_) -> + section oc (Section_debug_info s); + print_debug_info oc d l e) entries; + section oc Section_debug_loc; + List.iter (fun (_,_,_,_,l) -> print_location_list oc l) entries + + let print_gnu_entries oc cp loc = + compute_abbrev cp; + let line_start = new_label () + and start = new_label () + and abbrev_start = new_label () in + abbrev_start_addr := abbrev_start; + section oc (Section_debug_info ""); + print_debug_info oc start line_start cp; + print_abbrev oc; + section oc Section_debug_loc; + print_location_list oc loc; + section oc (Section_debug_line ""); + print_label oc line_start (* Print the debug info and abbrev section *) - let print_debug oc entry = - print_debug_abbrev oc entry; - print_debug_info oc entry + let print_debug oc = function + | Diab entries -> print_diab_entries oc entries + | Gnu (cp,loc) -> print_gnu_entries oc cp loc end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 9e0e6693..e1e10601 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -12,7 +12,7 @@ open DwarfTypes -module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) -> +module DwarfPrinter: functor (Target: DWARF_TARGET) -> sig - val print_debug: out_channel -> dw_entry -> unit + val print_debug: out_channel -> debug_entries -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index eaf07e1e..8f03eb8d 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -12,6 +12,8 @@ (* Types used for writing dwarf debug information *) +open BinNums +open Camlcoq open Sections (* Basic types for the value of attributes *) @@ -36,12 +38,20 @@ type address = int type block = string -type location_value = - | LocConst of constant - | LocBlock of block +type location_expression = + | DW_OP_plus_uconst of constant + | DW_OP_bregx of int * int32 + | DW_OP_piece of int + | DW_OP_reg of int +type location_value = + | LocSymbol of atom + | LocRef of address + | LocSimple of location_expression + | LocList of location_expression list + type data_location_value = - | DataLocBlock of block + | DataLocBlock of location_expression | DataLocRef of reference type bound_value = @@ -50,8 +60,10 @@ type bound_value = (* Types representing the attribute information per tag value *) -type file_loc = string * constant - +type file_loc = + | Diab_file_loc of int * constant + | Gnu_file_loc of int * constant + type dw_tag_array_type = { array_type_file_loc: file_loc option; @@ -67,7 +79,9 @@ type dw_tag_base_type = type dw_tag_compile_unit = { - compile_unit_name: string; + compile_unit_name: string; + compile_unit_low_pc: int; + compile_unit_high_pc: int; } type dw_tag_const_type = @@ -94,11 +108,10 @@ type dw_tag_formal_parameter = { formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; - formal_parameter_location: location_value option; formal_parameter_name: string option; - formal_parameter_segment: location_value option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; + formal_parameter_location: location_value option; } type dw_tag_label = @@ -109,8 +122,8 @@ type dw_tag_label = type dw_tag_lexical_block = { - lexical_block_high_pc: address; - lexical_block_low_pc: address; + lexical_block_high_pc: address option; + lexical_block_low_pc: address option; } type dw_tag_member = @@ -140,12 +153,13 @@ type dw_tag_structure_type = type dw_tag_subprogram = { - subprogram_file_loc: file_loc option; - subprogram_external: flag option; - subprogram_frame_base: location_value option; + subprogram_file_loc: file_loc; + subprogram_external: flag option; subprogram_name: string; subprogram_prototyped: flag; - subprogram_type: reference option; + subprogram_type: reference option; + subprogram_high_pc: reference option; + subprogram_low_pc: reference option; } type dw_tag_subrange_type = @@ -183,13 +197,12 @@ type dw_tag_unspecified_parameter = type dw_tag_variable = { - variable_file_loc: file_loc option; + variable_file_loc: file_loc; variable_declaration: flag option; variable_external: flag option; - variable_location: location_value option; variable_name: string; - variable_segment: location_value option; variable_type: reference; + variable_location: location_value option; } type dw_tag_volatile_type = @@ -228,46 +241,26 @@ type dw_entry = id: reference; } -(* Module type for a matching from type to dwarf encoding *) -module type DWARF_ABBREVS = - sig - val sibling_type_abbr: int - val file_loc_type_abbr: int * int - val type_abbr: int - val name_type_abbr: int - val encoding_type_abbr: int - val byte_size_type_abbr: int - val member_size_abbr: int - val high_pc_type_abbr: int - val low_pc_type_abbr: int - val stmt_list_type_abbr: int - val declaration_type_abbr: int - val external_type_abbr: int - val prototyped_type_abbr: int - val bit_offset_type_abbr: int - val comp_dir_type_abbr: int - val language_type_abbr: int - val producer_type_abbr: int - val value_type_abbr: int - val artificial_type_abbr: int - val variable_parameter_type_abbr: int - val bit_size_type_abbr: int - val location_const_type_abbr: int - val location_block_type_abbr: int - val data_location_block_type_abbr: int - val data_location_ref_type_abbr: int - val bound_const_type_abbr: int - val bound_ref_type_abbr: int - end +(* The type for the location list. *) +type location_entry = + { + loc: (int * int * location_value) list; + loc_id: reference; + } +type dw_locations = int option * location_entry list + +type diab_entries = (string * int * int * dw_entry * dw_locations) list + +type gnu_entries = dw_entry * dw_locations + +type debug_entries = + | Diab of diab_entries + | Gnu of gnu_entries (* The target specific functions for printing the debug information *) module type DWARF_TARGET= sig val label: out_channel -> int -> unit - val print_file_loc: out_channel -> file_loc -> unit - val get_start_addr: unit -> int - val get_end_addr: unit -> int - val get_stmt_list_addr: unit -> int - val name_of_section: section_name -> string - val get_fun_addr: string -> (int * int) option + val section: out_channel -> section_name -> unit + val symbol: out_channel -> atom -> unit end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index f47c2b58..16e446ee 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -14,18 +14,8 @@ open DwarfTypes -let id = ref 0 - -let next_id () = - let nid = !id in - incr id; nid - -let reset_id () = - id := 0 - (* Generate a new entry from a given tag *) -let new_entry tag = - let id = next_id () in +let new_entry id tag = { tag = tag; children = []; @@ -86,34 +76,67 @@ let dw_form_ref8 = 0x14 let dw_ref_udata = 0x15 let dw_ref_indirect = 0x16 +(* Operation encoding *) +let dw_op_addr = 0x3 +let dw_op_plus_uconst = 0x23 +let dw_op_reg0 = 0x50 +let dw_op_regx = 0x90 +let dw_op_bregx = 0x92 +let dw_op_piece = 0x93 + + (* Default corresponding encoding for the different abbreviations *) -module DefaultAbbrevs = - struct - let sibling_type_abbr = dw_form_ref4 - let file_loc_type_abbr = dw_form_data4,dw_form_udata - let type_abbr = dw_form_ref_addr - let name_type_abbr = dw_form_string - let encoding_type_abbr = dw_form_data1 - let byte_size_type_abbr = dw_form_data1 - let member_size_abbr = dw_form_udata - let high_pc_type_abbr = dw_form_addr - let low_pc_type_abbr = dw_form_addr - let stmt_list_type_abbr = dw_form_data4 - let declaration_type_abbr = dw_form_flag - let external_type_abbr = dw_form_flag - let prototyped_type_abbr = dw_form_flag - let bit_offset_type_abbr = dw_form_data1 - let comp_dir_type_abbr = dw_form_string - let language_type_abbr = dw_form_udata - let producer_type_abbr = dw_form_string - let value_type_abbr = dw_form_sdata - let artificial_type_abbr = dw_form_flag - let variable_parameter_type_abbr = dw_form_flag - let bit_size_type_abbr = dw_form_data1 - let location_const_type_abbr = dw_form_data4 - let location_block_type_abbr = dw_form_block - let data_location_block_type_abbr = dw_form_block - let data_location_ref_type_abbr = dw_form_ref4 - let bound_const_type_abbr = dw_form_udata - let bound_ref_type_abbr=dw_form_ref4 - end +let sibling_type_abbr = dw_form_ref4 +let file_loc_type_abbr = dw_form_data4,dw_form_udata +let type_abbr = dw_form_ref_addr +let name_type_abbr = dw_form_string +let encoding_type_abbr = dw_form_data1 +let byte_size_type_abbr = dw_form_data1 +let member_size_abbr = dw_form_udata +let high_pc_type_abbr = dw_form_addr +let low_pc_type_abbr = dw_form_addr +let stmt_list_type_abbr = dw_form_data4 +let declaration_type_abbr = dw_form_flag +let external_type_abbr = dw_form_flag +let prototyped_type_abbr = dw_form_flag +let bit_offset_type_abbr = dw_form_data1 +let comp_dir_type_abbr = dw_form_string +let language_type_abbr = dw_form_udata +let producer_type_abbr = dw_form_string +let value_type_abbr = dw_form_sdata +let artificial_type_abbr = dw_form_flag +let variable_parameter_type_abbr = dw_form_flag +let bit_size_type_abbr = dw_form_data1 +let location_ref_type_abbr = dw_form_data4 +let location_block_type_abbr = dw_form_block +let data_location_block_type_abbr = dw_form_block +let data_location_ref_type_abbr = dw_form_ref4 +let bound_const_type_abbr = dw_form_udata +let bound_ref_type_abbr=dw_form_ref4 + +(* Sizeof functions for the encoding of uleb128 and sleb128 *) +let sizeof_uleb128 value = + let size = ref 1 in + let value = ref (value lsr 7) in + while !value <> 0 do + value := !value lsr 7; + incr size; + done; + !size + +let sizeof_sleb128 value = + let size = ref 1 in + let byte = ref (value land 0x7f) in + let value = ref (value lsr 7) in + while not ((!value = 0 && (!byte land 0x40) = 0) || (!value = -1 && ((!byte land 0x40) <> 0))) do + byte := !value land 0x7f; + value := !value lsr 7; + incr size; + done; + !size + +let size_of_loc_expr = function + | DW_OP_bregx (a,b) -> 1 + (sizeof_uleb128 a) + (sizeof_sleb128 (Int32.to_int b)) + | DW_OP_plus_uconst a + | DW_OP_piece a -> 1 + (sizeof_uleb128 a) + | DW_OP_reg i -> if i < 32 then 1 else 2 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml new file mode 100644 index 00000000..eff80110 --- /dev/null +++ b/debug/Dwarfgen.ml @@ -0,0 +1,490 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open C +open Camlcoq +open Cutil +open DebugInformation +open DebugTypes +open DwarfTypes +open DwarfUtil + +(* Generate the dwarf DIE's from the information collected in DebugInformation *) + +(* Helper function to get values that must be set. *) +let get_opt_val = function + | Some a -> a + | None -> assert false + +(* Auxiliary data structures and functions *) +module IntSet = Set.Make(struct + type t = int + let compare (x:int) (y:int) = compare x y +end) + +let rec mmap f env = function + | [] -> ([],env) + | hd :: tl -> + let (hd',env1) = f env hd in + let (tl', env2) = mmap f env1 tl in + (hd' :: tl', env2) + +let rec mmap_opt f env = function + | [] -> ([],env) + | hd :: tl -> + let (hd',env1) = f env hd in + let (tl', env2) = mmap_opt f env1 tl in + begin + match hd' with + | Some hd -> (hd :: tl', env2) + | None -> tl',env2 + end + +(* Functions to translate the basetypes. *) +let int_type_to_entry id i = + let encoding = + (match i.int_kind with + | IBool -> DW_ATE_boolean + | IChar -> + if !Machine.config.Machine.char_signed then + DW_ATE_signed_char + else + DW_ATE_unsigned_char + | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed + | _ -> DW_ATE_unsigned)in + let int = { + base_type_byte_size = sizeof_ikind i.int_kind; + base_type_encoding = Some encoding; + base_type_name = typ_to_string (TInt (i.int_kind,[]));} in + new_entry id (DW_TAG_base_type int) + +let float_type_to_entry id f = + let byte_size = sizeof_fkind f.float_kind in + let float = { + base_type_byte_size = byte_size; + base_type_encoding = Some DW_ATE_float; + base_type_name = typ_to_string (TFloat (f.float_kind,[])); + } in + new_entry id (DW_TAG_base_type float) + +let void_to_entry id = + let void = { + base_type_byte_size = 0; + base_type_encoding = None; + base_type_name = "void"; + } in + new_entry id (DW_TAG_base_type void) + +let file_loc_opt file = function + | None -> None + | Some (f,l) -> + try + Some (file (f,l)) + with Not_found -> None + +let typedef_to_entry file id t = + let i = get_opt_val t.typ in + let td = { + typedef_file_loc = file_loc_opt file t.typedef_file_loc; + typedef_name = t.typedef_name; + typedef_type = i; + } in + new_entry id (DW_TAG_typedef td) + +let pointer_to_entry id p = + let p = {pointer_type = p.pts} in + new_entry id (DW_TAG_pointer_type p) + +let array_to_entry id arr = + let arr_tag = { + array_type_file_loc = None; + array_type = arr.arr_type; + } in + let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in + let children = List.map (fun a -> + let r = match a with + | None -> None + | Some i -> + let bound = Int64.to_int (Int64.sub i Int64.one) in + Some (BoundConst bound) in + let s = { + subrange_type = None; + subrange_upper_bound = r; + } in + new_entry (next_id ()) (DW_TAG_subrange_type s)) arr.arr_size in + add_children arr_entry children + +let const_to_entry id c = + new_entry id (DW_TAG_const_type ({const_type = c.cst_type})) + +let volatile_to_entry id v = + new_entry id (DW_TAG_volatile_type ({volatile_type = v.vol_type})) + +let enum_to_entry file id e = + let enumerator_to_entry e = + let tag = + { + enumerator_file_loc = None; + enumerator_value = Int64.to_int (e.enumerator_const); + enumerator_name = e.enumerator_name; + } in + new_entry (next_id ()) (DW_TAG_enumerator tag) in + let bs = sizeof_ikind enum_ikind in + let enum = { + enumeration_file_loc = file_loc_opt file e.enum_file_loc; + enumeration_byte_size = bs; + enumeration_declaration = Some false; + enumeration_name = Some e.enum_name; + } in + let enum = new_entry id (DW_TAG_enumeration_type enum) in + let child = List.map enumerator_to_entry e.enum_enumerators in + add_children enum child + +let fun_type_to_entry id f = + let children = if f.fun_prototyped then + let u = { + unspecified_parameter_file_loc = None; + unspecified_parameter_artificial = None; + } in + [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] + else + List.map (fun p -> + let fp = { + formal_parameter_file_loc = None; + formal_parameter_artificial = None; + formal_parameter_name = if p.param_name <> "" then Some p.param_name else None; + formal_parameter_type = p.param_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = None; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; + in + let s = { + subroutine_type = f.fun_return_type; + subroutine_prototyped = f.fun_prototyped + } in + let s = new_entry id (DW_TAG_subroutine_type s) in + add_children s children + +let member_to_entry mem = + let mem = { + member_file_loc = None; + member_byte_size = mem.cfd_byte_size; + member_bit_offset = mem.cfd_bit_offset; + member_bit_size = mem.cfd_bit_size; + member_data_member_location = + (match mem.cfd_byte_offset with + | None -> None + | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); + member_declaration = None; + member_name = Some (mem.cfd_name); + member_type = mem.cfd_typ; + } in + new_entry (next_id ()) (DW_TAG_member mem) + +let struct_to_entry file id s = + let tag = { + structure_file_loc = file_loc_opt file s.ct_file_loc; + structure_byte_size = s.ct_sizeof; + structure_declaration = if s.ct_declaration then Some s.ct_declaration else None; + structure_name = if s.ct_name <> "" then Some s.ct_name else None; + } in + let entry = new_entry id (DW_TAG_structure_type tag) in + let child = List.map member_to_entry s.ct_members in + add_children entry child + +let union_to_entry file id s = + let tag = { + union_file_loc = file_loc_opt file s.ct_file_loc; + union_byte_size = s.ct_sizeof; + union_declaration = if s.ct_declaration then Some s.ct_declaration else None; + union_name = if s.ct_name <> "" then Some s.ct_name else None; + } in + let entry = new_entry id (DW_TAG_union_type tag) in + let child = List.map member_to_entry s.ct_members in + add_children entry child + +let composite_to_entry file id s = + match s.ct_sou with + | Struct -> struct_to_entry file id s + | Union -> union_to_entry file id s + +let infotype_to_entry file id = function + | IntegerType i -> int_type_to_entry id i + | FloatType f -> float_type_to_entry id f + | PointerType p -> pointer_to_entry id p + | ArrayType arr -> array_to_entry id arr + | CompositeType c -> composite_to_entry file id c + | EnumType e -> enum_to_entry file id e + | FunctionType f -> fun_type_to_entry id f + | Typedef t -> typedef_to_entry file id t + | ConstType c -> const_to_entry id c + | VolatileType v -> volatile_to_entry id v + | Void -> void_to_entry id + +let needs_types id d = + let add_type id d = + if not (IntSet.mem id d) then + IntSet.add id d,true + else + d,false in + let t = Hashtbl.find types id in + match t with + | IntegerType _ + | FloatType _ + | Void + | EnumType _ -> d,false + | Typedef t -> + add_type (get_opt_val t.typ) d + | PointerType p -> + add_type p.pts d + | ArrayType arr -> + add_type arr.arr_type d + | ConstType c -> + add_type c.cst_type d + | VolatileType v -> + add_type v.vol_type d + | FunctionType f -> + let d,c = match f.fun_return_type with + | Some t -> add_type t d + | None -> d,false in + List.fold_left (fun (d,c) p -> + let d,c' = add_type p.param_type d in + d,c||c') (d,c) f.fun_params + | CompositeType c -> + List.fold_left (fun (d,c) f -> + let d,c' = add_type f.cfd_typ d in + d,c||c') (d,false) c.ct_members + +let gen_types file needed = + let rec aux d = + let d,c = IntSet.fold (fun id (d,c) -> + let d,c' = needs_types id d in + d,c||c') d (d,false) in + if c then + aux d + else + d in + let typs = aux needed in + List.rev (Hashtbl.fold (fun id t acc -> + if IntSet.mem id typs then + (infotype_to_entry file id t)::acc + else + acc) types []) + +let global_variable_to_entry file acc id v = + let loc = match v.gvar_atom with + | Some a when StringSet.mem (extern_atom a) !printed_vars -> + Some (LocSymbol a) + | _ -> None in + let var = { + variable_file_loc = file v.gvar_file_loc; + variable_declaration = Some v.gvar_declaration; + variable_external = Some v.gvar_external; + variable_name = v.gvar_name; + variable_type = v.gvar_type; + variable_location = loc; + } in + new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc + +let gen_splitlong op_hi op_lo = + let op_piece = DW_OP_piece 4 in + op_piece::op_hi@(op_piece::op_lo) + +let translate_function_loc a = function + | BA_addrstack (ofs) -> + let ofs = camlint_of_coqint ofs in + Some (LocSimple (DW_OP_bregx (a,ofs))),[] + | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> + let hi = camlint_of_coqint hi + and lo = camlint_of_coqint lo in + if lo = Int32.add hi 4l then + Some (LocSimple (DW_OP_bregx (a,hi))),[] + else + let op_hi = [DW_OP_bregx (a,hi)] + and op_lo = [DW_OP_bregx (a,lo)] in + Some (LocList (gen_splitlong op_hi op_lo)),[] + | _ -> None,[] + +let range_entry_loc (sp,l) = + let rec aux = function + | BA i -> [DW_OP_reg i] + | BA_addrstack ofs -> + let ofs = camlint_of_coqint ofs in + [DW_OP_bregx (sp,ofs)] + | BA_splitlong (hi,lo) -> + let hi = aux hi + and lo = aux lo in + gen_splitlong hi lo + | _ -> assert false in + match aux l with + | [] -> assert false + | [a] -> LocSimple a + | a::rest -> LocList (a::rest) + +let location_entry f_id atom = + try + begin + match (Hashtbl.find var_locations (f_id,atom)) with + | FunctionLoc (a,r) -> + translate_function_loc a r + | RangeLoc l -> + let l = List.rev_map (fun i -> + let hi = get_opt_val i.range_start + and lo = get_opt_val i.range_end in + let hi = Hashtbl.find label_translation (f_id,hi) + and lo = Hashtbl.find label_translation (f_id,lo) in + hi,lo,range_entry_loc i.var_loc) l in + let id = next_id () in + Some (LocRef id),[{loc = l;loc_id = id;}] + end + with Not_found -> None,[] + +let function_parameter_to_entry f_id (acc,bcc) p = + let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in + let p = { + formal_parameter_file_loc = None; + formal_parameter_artificial = None; + formal_parameter_name = Some p.parameter_name; + formal_parameter_type = p.parameter_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = loc; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter p),(IntSet.add p.formal_parameter_type acc,loc_list@bcc) + +let rec local_variable_to_entry file f_id (acc,bcc) v id = + match v.lvar_atom with + | None -> None,(acc,bcc) + | Some loc -> + let loc,loc_list = location_entry f_id loc in + let var = { + variable_file_loc = file v.lvar_file_loc; + variable_declaration = None; + variable_external = None; + variable_name = v.lvar_name; + variable_type = v.lvar_type; + variable_location = loc; + } in + Some (new_entry id (DW_TAG_variable var)),(IntSet.add v.lvar_type acc,loc_list@bcc) + +and scope_to_entry file f_id acc sc id = + let l_pc,h_pc = try + let r = Hashtbl.find scope_ranges id in + let lbl l = match l with + | Some l -> Some (Hashtbl.find label_translation (f_id,l)) + | None -> None in + begin + match r with + | [] -> None,None + | [a] -> lbl a.start_addr, lbl a.end_addr + | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr + end + with Not_found -> None,None in + let scope = { + lexical_block_high_pc = h_pc; + lexical_block_low_pc = l_pc; + } in + let vars,acc = mmap_opt (local_to_entry file f_id) acc sc.scope_variables in + let entry = new_entry id (DW_TAG_lexical_block scope) in + add_children entry vars,acc + +and local_to_entry file f_id acc id = + match Hashtbl.find local_variables id with + | LocalVariable v -> local_variable_to_entry file f_id acc v id + | Scope v -> let s,acc = + (scope_to_entry file f_id acc v id) in + Some s,acc + +let fun_scope_to_entries file f_id acc id = + match id with + | None -> [],acc + | Some id -> + let sc = Hashtbl.find local_variables id in + (match sc with + | Scope sc ->mmap_opt (local_to_entry file f_id) acc sc.scope_variables + | _ -> assert false) + +let function_to_entry file (acc,bcc) id f = + let f_tag = { + subprogram_file_loc = file f.fun_file_loc; + subprogram_external = Some f.fun_external; + subprogram_name = f.fun_name; + subprogram_prototyped = true; + subprogram_type = f.fun_return_type; + subprogram_high_pc = f.fun_high_pc; + subprogram_low_pc = f.fun_low_pc; + } in + let f_id = get_opt_val f.fun_atom in + let acc = match f.fun_return_type with Some s -> IntSet.add s acc | None -> acc in + let f_entry = new_entry id (DW_TAG_subprogram f_tag) in + let params,(acc,bcc) = mmap (function_parameter_to_entry f_id) (acc,bcc) f.fun_parameter in + let vars,(acc,bcc) = fun_scope_to_entries file f_id (acc,bcc) f.fun_scope in + add_children f_entry (params@vars),(acc,bcc) + +let definition_to_entry file (acc,bcc) id t = + match t with + | GlobalVariable g -> let e,acc = global_variable_to_entry file acc id g in + e,(acc,bcc) + | Function f -> function_to_entry file (acc,bcc) id f + +module StringMap = Map.Make(String) + +let diab_file_loc sec (f,l) = + Diab_file_loc (Hashtbl.find filenum (sec,f),l) + +let gen_diab_debug_info sec_name var_section : debug_entries = + let defs = Hashtbl.fold (fun id t acc -> + let s = match t with + | GlobalVariable _ -> var_section + | Function f -> sec_name (get_opt_val f.fun_atom) in + let old = try StringMap.find s acc with Not_found -> [] in + StringMap.add s ((id,t)::old) acc) definitions StringMap.empty in + let entries = StringMap.fold (fun s defs acc -> + let defs,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) -> + let t,bcc = definition_to_entry (diab_file_loc s) bcc id t in + t::acc,bcc) ([],(IntSet.empty,[])) defs in + let low_pc = Hashtbl.find compilation_section_start s + and line_start,debug_start,_ = Hashtbl.find diab_additional s + and high_pc = Hashtbl.find compilation_section_end s in + let cp = { + compile_unit_name = !file_name; + compile_unit_low_pc = low_pc; + compile_unit_high_pc = high_pc; + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + let cp = add_children cp ((gen_types (diab_file_loc s) ty) @ defs) in + (s,debug_start,line_start,cp,(Some low_pc,locs))::acc) defs [] in + Diab entries + +let gnu_file_loc (f,l) = + Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) + +let gen_gnu_debug_info sec_name var_section : debug_entries = + let low_pc = Hashtbl.find compilation_section_start ".text" + and high_pc = Hashtbl.find compilation_section_end ".text" in + let defs,(ty,locs),sec = Hashtbl.fold (fun id t (acc,bcc,sec) -> + let s = match t with + | GlobalVariable _ -> var_section + | Function f -> sec_name (get_opt_val f.fun_atom) in + let t,bcc = definition_to_entry gnu_file_loc bcc id t in + t::acc,bcc,StringSet.add s sec) definitions ([],(IntSet.empty,[]),StringSet.empty) in + let types = gen_types gnu_file_loc ty in + let cp = { + compile_unit_name = !file_name; + compile_unit_low_pc = low_pc; + compile_unit_high_pc = high_pc; + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + let cp = add_children cp (types@defs) in + let loc_pc = if StringSet.cardinal sec > 1 then None else Some low_pc in + Gnu (cp,(loc_pc,locs)) diff --git a/driver/Driver.ml b/driver/Driver.ml index f53de821..c7d9984e 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -108,6 +108,7 @@ let preprocess ifile ofile = (* From preprocessed C to Csyntax *) let parse_c_file sourcename ifile = + Debug.init_compile_unit sourcename; Sections.initialize(); (* Simplification options *) let simplifs = @@ -117,10 +118,10 @@ let parse_c_file sourcename ifile = ^ (if !option_fpacked_structs then "p" else "") in (* Parsing and production of a simplified C AST *) - let ast,debug = + let ast = match Parse.preprocessed_file simplifs sourcename ifile with - | None,_ -> exit 2 - | Some p,d -> p,d in + | None -> exit 2 + | Some p -> p in (* Save C AST if requested *) if !option_dparse then begin let ofile = output_filename sourcename ".c" ".parsed.c" in @@ -141,7 +142,7 @@ let parse_c_file sourcename ifile = PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax; close_out oc end; - csyntax,debug + csyntax,None (* Dump Asm code in binary format for the validator *) @@ -571,8 +572,10 @@ let cmdline_actions = Prefix "-L", Self push_linker_arg; Exact "-T", String (fun s -> if Configuration.system = "diab" then push_linker_arg ("-Wm"^s) - else - push_linker_arg ("-T "^s)); + else begin + push_linker_arg ("-T"); + push_linker_arg(s) + end); Prefix "-Wl,", Self push_linker_arg; (* Tracing options *) Exact "-dparse", Set option_dparse; @@ -682,6 +685,7 @@ let _ = Builtins.set C2C.builtins; CPragmas.initialize(); parse_cmdline cmdline_actions; + DebugInit.init (); (* Initialize the debug functions *) let nolink = !option_c || !option_S || !option_E || !option_interp in if nolink && !option_o <> None && !num_source_files >= 2 then begin eprintf "Ambiguous '-o' option (multiple source files)\n"; diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index 9563d551..82066cc9 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -250,10 +250,6 @@ let external_function p = function fprintf p "(EF_vload %s)" (name_of_chunk chunk) | EF_vstore chunk -> fprintf p "(EF_vstore %s)" (name_of_chunk chunk) - | EF_vload_global(chunk, id, ofs) -> - fprintf p "(EF_vload_global %s %a %a)" (name_of_chunk chunk) ident id coqint ofs - | EF_vstore_global(chunk, id, ofs) -> - fprintf p "(EF_vstore_global %s %a %a)" (name_of_chunk chunk) ident id coqint ofs | EF_malloc -> fprintf p "EF_malloc" | EF_free -> fprintf p "EF_free" | EF_memcpy(sz, al) -> @@ -264,6 +260,8 @@ let external_function p = function | EF_annot_val(text, targ) -> assertions := (text, [targ]) :: !assertions; fprintf p "(EF_annot_val %ld%%positive %a)" (P.to_int32 text) asttype targ + | EF_debug(kind, text, targs) -> + fprintf p "(EF_debug %ld%%positive %ld%%positive %a)" (P.to_int32 kind) (P.to_int32 text) (print_list asttype) targs | EF_inline_asm(text, sg, clob) -> fprintf p "@[<hov 2>(EF_inline_asm %ld%%positive@ %a@ %a)@]" (P.to_int32 text) diff --git a/extraction/extraction.v b/extraction/extraction.v index 6327f871..dc7522b8 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -168,4 +168,5 @@ Separate Extraction Machregs.mregs_for_operation Machregs.mregs_for_builtin Machregs.two_address_op Machregs.is_stack_reg AST.signature_main + AST.transform_partial_ident_program Parser.translation_unit_file. diff --git a/flocq/Appli/Fappli_IEEE.v b/flocq/Appli/Fappli_IEEE.v index 9b5826c1..23999a50 100644 --- a/flocq/Appli/Fappli_IEEE.v +++ b/flocq/Appli/Fappli_IEEE.v @@ -48,9 +48,9 @@ Section Binary. Implicit Arguments exist [[A] [P]]. -(** prec is the number of bits of the mantissa including the implicit one - emax is the exponent of the infinities - Typically p=24 and emax = 128 in single precision *) +(** [prec] is the number of bits of the mantissa including the implicit one; + [emax] is the exponent of the infinities. + For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) Variable prec emax : Z. Context (prec_gt_0_ : Prec_gt_0 prec). Hypothesis Hmax : (prec < emax)%Z. @@ -74,8 +74,7 @@ Definition valid_binary x := end. (** Basic type used for representing binary FP numbers. - Note that there is exactly one such object per FP datum. - NaNs do not have any payload. They cannot be distinguished. *) + Note that there is exactly one such object per FP datum. *) Definition nan_pl := {pl | (Zpos (digits2_pos pl) <? prec)%Z = true}. @@ -382,6 +381,8 @@ Proof. now intros [| |? []|]. Qed. +(** Opposite *) + Definition Bopp opp_nan x := match x with | B754_nan sx plx => @@ -647,7 +648,8 @@ generalize (prec_gt_0 prec). clear -Hmax ; omega. Qed. -(** mantissa, round and sticky bits *) +(** Truncation *) + Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. Definition shr_1 mrs := @@ -695,7 +697,7 @@ Qed. Definition shr mrs e n := match n with - | Zpos p => (iter_pos p _ shr_1 mrs, (e + n)%Z) + | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) | _ => (mrs, e) end. @@ -746,24 +748,24 @@ destruct n as [|n|n]. now destruct l as [|[| |]]. 2: now destruct l as [|[| |]]. unfold shr. -rewrite iter_nat_of_P. +rewrite iter_pos_nat. rewrite Zpos_eq_Z_of_nat_o_nat_of_P. induction (nat_of_P n). simpl. rewrite Zplus_0_r. now destruct l as [|[| |]]. -simpl nat_rect. +rewrite iter_nat_S. rewrite inj_S. unfold Zsucc. -rewrite Zplus_assoc. +rewrite Zplus_assoc. revert IHn0. apply inbetween_shr_1. clear -Hm. induction n0. now destruct l as [|[| |]]. -simpl. +rewrite iter_nat_S. revert IHn0. -generalize (iter_nat n0 shr_record shr_1 (shr_record_of_loc m l)). +generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). clear. intros (m, r, s) Hm. now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. @@ -827,6 +829,8 @@ intros H. now inversion H. Qed. +(** Rounding modes *) + Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. Definition round_mode m := @@ -927,7 +931,6 @@ destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). rewrite shr_m_shr_record_of_loc. intros Hm2. rewrite Hm2. -intros z. repeat split. rewrite Rlt_bool_true. repeat split. @@ -1178,6 +1181,8 @@ destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Hx], y as [sy|sy|sy [ply Hply]|sy my apply B2FF_FF2B. Qed. +(** Normalization and rounding *) + Definition shl_align mx ex ex' := match (ex' - ex)%Z with | Zneg d => (shift_pos d mx, ex') @@ -1361,6 +1366,7 @@ now apply F2R_lt_0_compat. Qed. (** Addition *) + Definition Bplus plus_nan m x y := let f pl := B754_nan (fst pl) (snd pl) in match x, y with @@ -1475,7 +1481,7 @@ elim Rle_not_lt with (1 := Bz). generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). intros Bx By (Hx',_) (Hy',_). generalize (canonic_canonic_mantissa sx _ _ Hx') (canonic_canonic_mantissa sy _ _ Hy'). -clear -Bx By Hs. +clear -Bx By Hs prec_gt_0_. intros Cx Cy. destruct sx. (* ... *) @@ -1542,6 +1548,8 @@ now apply f_equal. apply Sz. Qed. +(** Subtraction *) + Definition Bminus minus_nan m x y := Bplus minus_nan m x (Bopp pair y). Theorem Bminus_correct : @@ -1571,6 +1579,7 @@ rewrite is_finite_Bopp. auto. now destruct y as [ | | | ]. Qed. (** Division *) + Definition Fdiv_core_binary m1 e1 m2 e2 := let d1 := Zdigits2 m1 in let d2 := Zdigits2 m2 in @@ -1737,6 +1746,7 @@ now rewrite B2FF_FF2B. Qed. (** Square root *) + Definition Fsqrt_core_binary m e := let d := Zdigits2 m in let s := Zmax (2 * prec - d) 0 in diff --git a/flocq/Appli/Fappli_IEEE_bits.v b/flocq/Appli/Fappli_IEEE_bits.v index 5a77bf57..87aa1046 100644 --- a/flocq/Appli/Fappli_IEEE_bits.v +++ b/flocq/Appli/Fappli_IEEE_bits.v @@ -617,7 +617,7 @@ apply refl_equal. Qed. Definition default_nan_pl32 : bool * nan_pl 24 := - (false, exist _ (iter_nat 22 _ xO xH) (refl_equal true)). + (false, exist _ (iter_nat xO 22 xH) (refl_equal true)). Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 := match f with @@ -660,7 +660,7 @@ apply refl_equal. Qed. Definition default_nan_pl64 : bool * nan_pl 53 := - (false, exist _ (iter_nat 51 _ xO xH) (refl_equal true)). + (false, exist _ (iter_nat xO 51 xH) (refl_equal true)). Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 := match f with diff --git a/flocq/Appli/Fappli_double_round.v b/flocq/Appli/Fappli_double_round.v index f83abc47..3ff6c31a 100644 --- a/flocq/Appli/Fappli_double_round.v +++ b/flocq/Appli/Fappli_double_round.v @@ -72,12 +72,15 @@ assert (Hx2 : x - round beta fexp1 Zfloor x < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } set (x'' := round beta fexp2 (Znearest choice2) x). -assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))); - [now unfold x''; apply ulp_half_error|]. +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))). +apply Rle_trans with (/ 2 * ulp beta fexp2 x). +now unfold x''; apply error_le_half_ulp... +rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. assert (Pxx' : 0 <= x - x'). { apply Rle_0_minus. apply round_DN_pt. exact Vfexp1. } +rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption). assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))). { replace (x'' - x') with (x'' - x + (x - x')) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). @@ -114,6 +117,7 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. + (bpow (ln_beta x) - / 2 * bpow (fexp2 (ln_beta x)))) by ring. apply Rplus_le_lt_compat; [exact Hr1|]. + rewrite ulp_neq_0 in Hx1;[idtac| now apply Rgt_not_eq]. now rewrite Rabs_right; [|apply Rle_ge; apply Rlt_le]. - unfold x'' in Nzx'' |- *. now apply ln_beta_round_ge; [|apply valid_rnd_N|]. } @@ -168,12 +172,14 @@ assert (Pxx' : 0 <= x - x'). apply round_DN_pt. exact Vfexp1. } assert (x < bpow (ln_beta x) - / 2 * bpow (fexp2 (ln_beta x))); - [|now apply double_round_lt_mid_further_place']. + [|apply double_round_lt_mid_further_place'; try assumption]... +2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq]. destruct (Req_dec x' 0) as [Zx'|Nzx']. - (* x' = 0 *) rewrite Zx' in Hx2; rewrite Rminus_0_r in Hx2. apply (Rlt_le_trans _ _ _ Hx2). rewrite Rmult_minus_distr_l. + rewrite 2!ulp_neq_0;[idtac|now apply Rgt_not_eq|now apply Rgt_not_eq]. apply Rplus_le_compat_r. apply (Rmult_le_reg_r (bpow (- ln_beta x))); [now apply bpow_gt_0|]. unfold ulp, canonic_exp; bpow_simplify. @@ -199,7 +205,7 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. { apply (Rplus_le_reg_r (ulp beta fexp1 x)); ring_simplify. rewrite <- ulp_DN. - change (round _ _ _ _) with x'. - apply succ_le_bpow. + apply id_p_ulp_le_bpow. + exact Px'. + change x' with (round beta fexp1 Zfloor x). now apply generic_format_round; [|apply valid_rnd_DN]. @@ -210,10 +216,14 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. - exact Vfexp1. - exact Px'. } fold (canonic_exp beta fexp2 x); fold (ulp beta fexp2 x). - assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x); [|lra]. + assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x). rewrite <- (Rmult_1_l (ulp _ _ _)) at 2. apply Rmult_le_compat_r; [|lra]. - apply bpow_ge_0. + apply ulp_ge_0. + rewrite 2!ulp_neq_0 in Hx2;[|now apply Rgt_not_eq|now apply Rgt_not_eq]. + rewrite ulp_neq_0 in Hx';[|now apply Rgt_not_eq]. + rewrite ulp_neq_0 in H;[|now apply Rgt_not_eq]. + lra. Qed. Lemma double_round_lt_mid_same_place : @@ -256,7 +266,7 @@ assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) - rewrite <- (Rmult_0_r (/ 2)). apply Rmult_lt_compat_l; [lra|]. apply bpow_gt_0. - - exact Hx. } + - rewrite ulp_neq_0 in Hx;try apply Rgt_not_eq; assumption. } unfold round at 2. unfold F2R, scaled_mantissa, canonic_exp; simpl. rewrite Hf2f1. @@ -320,8 +330,10 @@ unfold double_round_eq. set (x' := round beta fexp1 Zceil x). set (x'' := round beta fexp2 (Znearest choice2) x). intros Hx1 Hx2. -assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))); - [now unfold x''; apply ulp_half_error|]. +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))). + apply Rle_trans with (/2* ulp beta fexp2 x). + now unfold x''; apply error_le_half_ulp... + rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. assert (Px'x : 0 <= x' - x). { apply Rle_0_minus. apply round_UP_pt. @@ -335,6 +347,7 @@ assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))). apply Rplus_le_lt_compat. - exact Hr1. - rewrite Rabs_minus_sym. + rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption). now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. } destruct (Req_dec x'' 0) as [Zx''|Nzx'']. - (* x'' = 0 *) @@ -382,7 +395,8 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply (Rlt_le_trans _ _ _ Hx2). apply Rmult_le_compat_l; [lra|]. generalize (bpow_ge_0 beta (fexp2 (ln_beta x))). - unfold ulp, canonic_exp; lra. + rewrite 2!ulp_neq_0; try (apply Rgt_not_eq; assumption). + unfold canonic_exp; lra. + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. @@ -422,7 +436,7 @@ assert (Hx''pow : x'' = bpow (ln_beta x)). { apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x). - apply (Rplus_le_reg_r (- x)); ring_simplify. apply Rabs_le_inv. - apply ulp_half_error. + apply error_le_half_ulp. exact Vfexp2. - apply Rplus_lt_compat_r. rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. @@ -442,15 +456,17 @@ assert (Hx''pow : x'' = bpow (ln_beta x)). apply (Rlt_le_trans _ _ _ H'x''). apply Rplus_le_compat_l. rewrite <- (Rmult_1_l (Fcore_Raux.bpow _ _)). + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. lra. } assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x). { apply Rle_lt_trans with (/ 2 * ulp beta fexp2 x). - rewrite Rabs_minus_sym. - apply ulp_half_error. + apply error_le_half_ulp. exact Vfexp2. - apply Rmult_lt_compat_l; [lra|]. - unfold ulp, canonic_exp; apply bpow_lt. + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq. + unfold canonic_exp; apply bpow_lt. omega. } unfold round, F2R, scaled_mantissa, canonic_exp; simpl. assert (Hf : (0 <= ln_beta x - fexp1 (ln_beta x''))%Z). @@ -475,6 +491,7 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). rewrite <- Rabs_mult. rewrite Rmult_minus_distr_r. bpow_simplify. + rewrite ulp_neq_0 in Hr;[idtac|now apply Rgt_not_eq]. rewrite <- Hx''pow; exact Hr. - rewrite Z2R_Zpower; [|exact Hf]. apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x'')))); [now apply bpow_gt_0|]. @@ -522,7 +539,7 @@ assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x)))) + apply Rle_0_minus. apply round_UP_pt. exact Vfexp1. - - exact Hx. } + - rewrite ulp_neq_0 in Hx;[exact Hx|now apply Rgt_not_eq]. } unfold double_round_eq, round at 2. unfold F2R, scaled_mantissa, canonic_exp; simpl. rewrite Hf2f1. @@ -761,9 +778,10 @@ destruct (Req_dec y 0) as [Zy|Nzy]. - (* y = 0 *) now rewrite Zy; rewrite Rplus_0_r. - (* y <> 0 *) - apply (ln_beta_succ beta fexp); [assumption|assumption|]. + apply (ln_beta_plus_eps beta fexp); [assumption|assumption|]. split; [assumption|]. - unfold ulp, canonic_exp. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. + unfold canonic_exp. destruct (ln_beta y) as (ey, Hey); simpl in *. apply Rlt_le_trans with (bpow ey). + now rewrite <- (Rabs_right y); [apply Hey|apply Rle_ge]. @@ -797,8 +815,7 @@ apply ln_beta_unique. split. - apply Rabs_ge; right. assert (Hy : y < ulp beta fexp (bpow (ln_beta x - 1))). - { unfold ulp, canonic_exp. - rewrite ln_beta_bpow. + { rewrite ulp_bpow. replace (_ + _)%Z with (ln_beta x : Z) by ring. rewrite <- (Rabs_right y); [|now apply Rle_ge; apply Rlt_le]. apply Rlt_le_trans with (bpow (ln_beta y)). @@ -808,7 +825,8 @@ split. apply Rle_trans with (bpow (ln_beta x - 1) + ulp beta fexp (bpow (ln_beta x - 1))). + now apply Rplus_le_compat_l; apply Rlt_le. - + apply succ_le_lt; [|exact Fx|now split; [apply bpow_gt_0|]]. + + rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0]. + apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption]. apply (generic_format_bpow beta fexp (ln_beta x - 1)). replace (_ + _)%Z with (ln_beta x : Z) by ring. assert (fexp (ln_beta x) < ln_beta x)%Z; [|omega]. @@ -1039,13 +1057,15 @@ apply double_round_lt_mid. apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px Py Hly Lxy Fx))). ring_simplify. - unfold ulp, canonic_exp; rewrite Lxy. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold canonic_exp; rewrite Lxy. apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rle_trans _ _ _ Bpow2). rewrite <- (Rmult_1_r (/ 2)) at 3. apply Rmult_le_compat_l; lra. -- unfold ulp, round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. +- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. intro Hf2'. apply (Rmult_lt_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. @@ -1056,7 +1076,8 @@ apply double_round_lt_mid. apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px Py Hly Lxy Fx))). apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. - unfold ulp, canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. apply (Rle_trans _ _ _ Bpow2). rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l. apply Rmult_le_compat_l; [lra|]. @@ -1391,7 +1412,8 @@ apply double_round_gt_mid. [now apply double_round_minus_aux2_aux; try assumption; omega|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. - + unfold ulp, canonic_exp. + + rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus]. + unfold canonic_exp. replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring. unfold Zminus at 1; rewrite bpow_plus. rewrite Rmult_comm. @@ -1423,7 +1445,8 @@ apply double_round_gt_mid. + unfold Fcore_Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. now change 2 with (Z2R 2); apply Z2R_le. - + unfold ulp, canonic_exp. + + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. + unfold canonic_exp. apply (Rplus_le_reg_r (bpow (fexp2 (ln_beta (x - y))))); ring_simplify. apply Rle_trans with (2 * bpow (fexp1 (ln_beta (x - y)) - 1)). * rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. @@ -1868,19 +1891,22 @@ apply double_round_lt_mid. apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px Py Hly Lxy Fx))). ring_simplify. - unfold ulp, canonic_exp; rewrite Lxy. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold canonic_exp; rewrite Lxy. apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rle_trans _ _ _ Bpow3); lra. -- unfold ulp, round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. +- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. intro Hf2'. unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))); ring_simplify. rewrite <- Rmult_minus_distr_l. apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px Py Hly Lxy Fx))). - unfold ulp, canonic_exp; rewrite Lxy. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold canonic_exp; rewrite Lxy. apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. rewrite (Rmult_assoc (/ 2)). @@ -2106,7 +2132,8 @@ apply double_round_gt_mid. [now apply double_round_minus_aux2_aux|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. - + unfold ulp, canonic_exp. + + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rgt_minus]. + unfold canonic_exp. unfold Zminus at 1; rewrite bpow_plus. rewrite Rmult_comm. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. @@ -2124,7 +2151,8 @@ apply double_round_gt_mid. apply (Rlt_le_trans _ _ _ Ly). apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 1)); [now apply bpow_le|]. - unfold ulp, canonic_exp. + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. + unfold canonic_exp. apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x - y))))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. @@ -2533,7 +2561,7 @@ destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. now apply (generic_inclusion_ln_beta beta fexp1); [omega|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = rd + u1); - [now apply ulp_DN_UP|]. + [now apply round_UP_DN_ulp|]. assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))). + (* x - rd < / 2 * (u1 - u2) *) @@ -2589,10 +2617,11 @@ assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } set (a := round beta fexp1 Zfloor (sqrt x)). -set (u1 := ulp beta fexp1 (sqrt x)). -set (u2 := ulp beta fexp2 (sqrt x)). +set (u1 := bpow (fexp1 (ln_beta (sqrt x)))). +set (u2 := bpow (fexp2 (ln_beta (sqrt x)))). set (b := / 2 * (u1 - u2)). set (b' := / 2 * (u1 + u2)). +unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. apply Rnot_ge_lt; intro H; apply Rge_le in H. assert (Fa : generic_format beta fexp1 a). { unfold a. @@ -2619,7 +2648,7 @@ assert (Pb : 0 < b). rewrite <- (Rmult_0_r (/ 2)). apply Rmult_lt_compat_l; [lra|]. apply Rlt_Rminus. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1. apply bpow_lt. omega. } assert (Pb' : 0 < b'). @@ -2686,7 +2715,7 @@ destruct (Req_dec a 0) as [Za|Nza]. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_round_DN. + { unfold a; apply ln_beta_DN. - exact Vfexp1. - now fold a. } assert (Hl' : 0 < - (u2 * a) + b * b). @@ -2697,12 +2726,14 @@ destruct (Req_dec a 0) as [Za|Nza]. replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field. apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))). - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. - unfold u1, ulp, canonic_exp; rewrite <- Hla. - apply Rlt_le_trans with (a + ulp beta fexp1 a). + unfold u1; rewrite <- Hla. + apply Rlt_le_trans with (a + bpow (fexp1 (ln_beta a))). + apply Rplus_lt_compat_l. - rewrite <- (Rmult_1_l (ulp _ _ _)). + rewrite <- (Rmult_1_l (bpow _)) at 2. apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. - + apply (succ_le_bpow _ _ _ _ Pa Fa). + + apply Rle_trans with (a+ ulp beta fexp1 a). + right; now rewrite ulp_neq_0. + apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). apply Rabs_lt_inv, bpow_ln_beta_gt. - apply Rle_trans with (bpow (- 2) * u1 ^ 2). + unfold pow; rewrite Rmult_1_r. @@ -2745,9 +2776,10 @@ destruct (Req_dec a 0) as [Za|Nza]. apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2). - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. apply Rlt_le_trans with (a + u1); [lra|]. - unfold u1. - rewrite <- ulp_DN; [|exact Vfexp1|exact Pa]; fold a. - apply succ_le_bpow. + unfold u1; fold (canonic_exp beta fexp1 (sqrt x)). + rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a. + rewrite <- ulp_neq_0; trivial. + apply id_p_ulp_le_bpow. + exact Pa. + now apply round_DN_pt. + apply Rle_lt_trans with (sqrt x). @@ -2782,21 +2814,6 @@ destruct (Req_dec a 0) as [Za|Nza]. + now apply Rle_trans with x. Qed. -(* --> Fcore_Raux *) -Lemma sqrt_neg : forall x, x <= 0 -> sqrt x = 0. -Proof. -intros x Npx. -destruct (Req_dec x 0) as [Zx|Nzx]. -- (* x = 0 *) - rewrite Zx. - exact sqrt_0. -- (* x < 0 *) - unfold sqrt. - destruct Rcase_abs. - + reflexivity. - + casetype False. - now apply Nzx, Rle_antisym; [|apply Rge_le]. -Qed. Lemma double_round_sqrt : forall fexp1 fexp2 : Z -> Z, @@ -3028,10 +3045,11 @@ Lemma double_round_sqrt_beta_ge_4_aux : Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx. set (a := round beta fexp1 Zfloor (sqrt x)). -set (u1 := ulp beta fexp1 (sqrt x)). -set (u2 := ulp beta fexp2 (sqrt x)). +set (u1 := bpow (fexp1 (ln_beta (sqrt x)))). +set (u2 := bpow (fexp2 (ln_beta (sqrt x)))). set (b := / 2 * (u1 - u2)). set (b' := / 2 * (u1 + u2)). +unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. apply Rnot_ge_lt; intro H; apply Rge_le in H. assert (Fa : generic_format beta fexp1 a). { unfold a. @@ -3125,7 +3143,7 @@ destruct (Req_dec a 0) as [Za|Nza]. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_round_DN. + { unfold a; apply ln_beta_DN. - exact Vfexp1. - now fold a. } assert (Hl' : 0 < - (u2 * a) + b * b). @@ -3136,12 +3154,13 @@ destruct (Req_dec a 0) as [Za|Nza]. replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field. apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))). - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. - unfold u1, ulp, canonic_exp; rewrite <- Hla. + unfold u1; rewrite <- Hla. apply Rlt_le_trans with (a + ulp beta fexp1 a). + apply Rplus_lt_compat_l. rewrite <- (Rmult_1_l (ulp _ _ _)). + rewrite ulp_neq_0; trivial. apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. - + apply (succ_le_bpow _ _ _ _ Pa Fa). + + apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). apply Rabs_lt_inv, bpow_ln_beta_gt. - apply Rle_trans with (bpow (- 1) * u1 ^ 2). + unfold pow; rewrite Rmult_1_r. @@ -3184,9 +3203,10 @@ destruct (Req_dec a 0) as [Za|Nza]. apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2). - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. apply Rlt_le_trans with (a + u1); [lra|]. - unfold u1. - rewrite <- ulp_DN; [|exact Vfexp1|exact Pa]; fold a. - apply succ_le_bpow. + unfold u1; fold (canonic_exp beta fexp1 (sqrt x)). + rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a. + rewrite <- ulp_neq_0; trivial. + apply id_p_ulp_le_bpow. + exact Pa. + now apply round_DN_pt. + apply Rle_lt_trans with (sqrt x). @@ -3504,9 +3524,11 @@ assert (Hf : F2R f = x). rewrite (Rmult_assoc _ (Z2R n)). rewrite Rinv_r; [rewrite Rmult_1_r|change 0 with (Z2R 0); apply Z2R_neq; omega]. - simpl; fold (canonic_exp beta fexp1 x); fold (ulp beta fexp1 x); fold u. - rewrite Xmid at 2. + simpl; fold (canonic_exp beta fexp1 x). + rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq. + fold u; rewrite Xmid at 2. apply f_equal2; [|reflexivity]. + rewrite ulp_neq_0; try now apply Rgt_not_eq. destruct (Req_dec rd 0) as [Zrd|Nzrd]. - (* rd = 0 *) rewrite Zrd. @@ -3657,7 +3679,7 @@ split. replace (bpow _) with (bpow (ln_beta x) - / 2 * u2 + / 2 * u2) by ring. apply Rplus_lt_le_compat; [exact Hx|]. apply Rabs_le_inv. - now apply ulp_half_error. + now apply error_le_half_ulp. Qed. Lemma double_round_all_mid_cases : @@ -3714,7 +3736,7 @@ destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]]. now apply (generic_inclusion_ln_beta beta fexp1); [omega|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = x' + u1); - [now apply ulp_DN_UP|]. + [now apply round_UP_DN_ulp|]. assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x); @@ -3769,12 +3791,15 @@ assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. set (p := bpow (ln_beta (x / y))). -set (u2 := ulp beta fexp2 (x / y)). +set (u2 := bpow (fexp2 (ln_beta (x / y)))). revert Fx Fy. unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). intros Fx Fy. +rewrite ulp_neq_0. +2: apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. +2: now apply Rinv_neq_0_compat, Rgt_not_eq. intro Hl. assert (Hr : x / y < p); [now apply Rabs_lt_inv; apply bpow_ln_beta_gt|]. @@ -3903,6 +3928,9 @@ assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (S : (x / y <> 0)%R). +apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. +now apply Rinv_neq_0_compat, Rgt_not_eq. cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y)) <= x / y - round beta fexp1 Zfloor (x / y) < / 2 * ulp beta fexp1 (x / y))). @@ -3913,9 +3941,10 @@ cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y)) - apply (Rplus_lt_reg_l (round beta fexp1 Zfloor (x / y))). ring_simplify. apply H'. } -set (u1 := ulp beta fexp1 (x / y)). -set (u2 := ulp beta fexp2 (x / y)). +set (u1 := bpow (fexp1 (ln_beta (x / y)))). +set (u2 := bpow (fexp2 (ln_beta (x / y)))). set (x' := round beta fexp1 Zfloor (x / y)). +rewrite 2!ulp_neq_0; trivial. revert Fx Fy. unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). @@ -4098,9 +4127,13 @@ cut (~ (/ 2 * ulp beta fexp1 (x / y) - apply (Rplus_le_reg_l (round beta fexp1 Zfloor (x / y))). ring_simplify. apply H'. } -set (u1 := ulp beta fexp1 (x / y)). -set (u2 := ulp beta fexp2 (x / y)). +set (u1 := bpow (fexp1 (ln_beta (x / y)))). +set (u2 := bpow (fexp2 (ln_beta (x / y)))). set (x' := round beta fexp1 Zfloor (x / y)). +assert (S : (x / y <> 0)%R). +apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. +now apply Rinv_neq_0_compat, Rgt_not_eq. +rewrite 2!ulp_neq_0; trivial. revert Fx Fy. unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). diff --git a/flocq/Appli/Fappli_rnd_odd.v b/flocq/Appli/Fappli_rnd_odd.v index b3244589..4741047f 100644 --- a/flocq/Appli/Fappli_rnd_odd.v +++ b/flocq/Appli/Fappli_rnd_odd.v @@ -356,6 +356,80 @@ simpl; ring. apply Rgt_not_eq, bpow_gt_0. Qed. + + +Theorem Rnd_odd_pt_unicity : + forall x f1 f2 : R, + Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 -> + f1 = f2. +Proof. +intros x f1 f2 (Ff1,H1) (Ff2,H2). +(* *) +case (generic_format_EM beta fexp x); intros L. +apply trans_eq with x. +case H1; try easy. +intros (J,_); case J; intros J'. +apply Rnd_DN_pt_idempotent with format; assumption. +apply Rnd_UP_pt_idempotent with format; assumption. +case H2; try easy. +intros (J,_); case J; intros J'; apply sym_eq. +apply Rnd_DN_pt_idempotent with format; assumption. +apply Rnd_UP_pt_idempotent with format; assumption. +(* *) +destruct H1 as [H1|(H1,H1')]. +contradict L; now rewrite <- H1. +destruct H2 as [H2|(H2,H2')]. +contradict L; now rewrite <- H2. +destruct H1 as [H1|H1]; destruct H2 as [H2|H2]. +apply Rnd_DN_pt_unicity with format x; assumption. +destruct H1' as (ff,(K1,(K2,K3))). +destruct H2' as (gg,(L1,(L2,L3))). +absurd (true = false); try discriminate. +rewrite <- L3. +apply trans_eq with (negb (Zeven (Fnum ff))). +rewrite K3; easy. +apply sym_eq. +generalize (DN_UP_parity_generic beta fexp). +unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... +rewrite <- K1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy... +now apply round_DN_pt... +rewrite <- L1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... +now apply round_UP_pt... +(* *) +destruct H1' as (ff,(K1,(K2,K3))). +destruct H2' as (gg,(L1,(L2,L3))). +absurd (true = false); try discriminate. +rewrite <- K3. +apply trans_eq with (negb (Zeven (Fnum gg))). +rewrite L3; easy. +apply sym_eq. +generalize (DN_UP_parity_generic beta fexp). +unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... +rewrite <- L1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy... +now apply round_DN_pt... +rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... +now apply round_UP_pt... +apply Rnd_UP_pt_unicity with format x; assumption. +Qed. + + + +Theorem Rnd_odd_pt_monotone : + round_pred_monotone (Rnd_odd_pt). +Proof with auto with typeclass_instances. +intros x y f g H1 H2 Hxy. +apply Rle_trans with (round beta fexp Zrnd_odd x). +right; apply Rnd_odd_pt_unicity with x; try assumption. +apply round_odd_pt. +apply Rle_trans with (round beta fexp Zrnd_odd y). +apply round_le... +right; apply Rnd_odd_pt_unicity with y; try assumption. +apply round_odd_pt. +Qed. + + + + End Fcore_rnd_odd. Section Odd_prop_aux. @@ -462,7 +536,7 @@ Lemma ln_beta_d: (0< F2R d)%R -> (ln_beta beta (F2R d) = ln_beta beta x :>Z). Proof with auto with typeclass_instances. intros Y. -rewrite d_eq; apply ln_beta_round_DN... +rewrite d_eq; apply ln_beta_DN... now rewrite <- d_eq. Qed. @@ -861,13 +935,9 @@ case K2; clear K2; intros K2. case (Rle_or_lt x m); intros Y;[destruct Y|idtac]. (* . *) apply trans_eq with (F2R d). -apply round_N_DN_betw with (F2R u)... +apply round_N_eq_DN_pt with (F2R u)... apply DN_odd_d_aux; split; try left; assumption. apply UP_odd_d_aux; split; try left; assumption. -split. -apply round_ge_generic... -apply generic_format_fexpe_fexp, Hd. -apply Hd. assert (o <= (F2R d + F2R u) / 2)%R. apply round_le_generic... apply Fm. @@ -876,10 +946,7 @@ destruct H1; trivial. apply P. now apply Rlt_not_eq. trivial. -apply sym_eq, round_N_DN_betw with (F2R u)... -split. -apply Hd. -exact H0. +apply sym_eq, round_N_eq_DN_pt with (F2R u)... (* . *) replace o with x. reflexivity. @@ -887,10 +954,9 @@ apply sym_eq, round_generic... rewrite H0; apply Fm. (* . *) apply trans_eq with (F2R u). -apply round_N_UP_betw with (F2R d)... +apply round_N_eq_UP_pt with (F2R d)... apply DN_odd_d_aux; split; try left; assumption. apply UP_odd_d_aux; split; try left; assumption. -split. assert ((F2R d + F2R u) / 2 <= o)%R. apply round_ge_generic... apply Fm. @@ -899,13 +965,7 @@ destruct H0; trivial. apply P. now apply Rgt_not_eq. rewrite <- H0; trivial. -apply round_le_generic... -apply generic_format_fexpe_fexp, Hu. -apply Hu. -apply sym_eq, round_N_UP_betw with (F2R d)... -split. -exact Y. -apply Hu. +apply sym_eq, round_N_eq_UP_pt with (F2R d)... Qed. diff --git a/flocq/Core/Fcore_FIX.v b/flocq/Core/Fcore_FIX.v index a3b8d4d0..e224a64a 100644 --- a/flocq/Core/Fcore_FIX.v +++ b/flocq/Core/Fcore_FIX.v @@ -22,6 +22,7 @@ Require Import Fcore_Raux. Require Import Fcore_defs. Require Import Fcore_rnd. Require Import Fcore_generic_fmt. +Require Import Fcore_ulp. Require Import Fcore_rnd_ne. Section RND_FIX. @@ -84,4 +85,16 @@ intros ex ey H. apply Zle_refl. Qed. +Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin. +Proof. +intros x; unfold ulp. +case Req_bool_spec; intros Zx. +case (negligible_exp_spec FIX_exp). +intros T; specialize (T (emin-1)%Z); contradict T. +unfold FIX_exp; omega. +intros n _; reflexivity. +reflexivity. +Qed. + + End RND_FIX. diff --git a/flocq/Core/Fcore_FLT.v b/flocq/Core/Fcore_FLT.v index 273ff69f..372af6ad 100644 --- a/flocq/Core/Fcore_FLT.v +++ b/flocq/Core/Fcore_FLT.v @@ -25,6 +25,7 @@ Require Import Fcore_generic_fmt. Require Import Fcore_float_prop. Require Import Fcore_FLX. Require Import Fcore_FIX. +Require Import Fcore_ulp. Require Import Fcore_rnd_ne. Section RND_FLT. @@ -222,7 +223,6 @@ Theorem generic_format_FLT_FIX : generic_format beta (FIX_exp emin) x -> generic_format beta FLT_exp x. Proof with auto with typeclass_instances. -clear prec_gt_0_. apply generic_inclusion_le... intros e He. unfold FIX_exp. @@ -231,6 +231,75 @@ omega. apply Zle_refl. Qed. +Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R -> + ulp beta FLT_exp x = bpow emin. +Proof with auto with typeclass_instances. +intros x Hx. +unfold ulp; case Req_bool_spec; intros Hx2. +(* x = 0 *) +case (negligible_exp_spec FLT_exp). +intros T; specialize (T (emin-1)%Z); contradict T. +apply Zle_not_lt; unfold FLT_exp. +apply Zle_trans with (2:=Z.le_max_r _ _); omega. +assert (V:FLT_exp emin = emin). +unfold FLT_exp; apply Z.max_r. +unfold Prec_gt_0 in prec_gt_0_; omega. +intros n H2; rewrite <-V. +apply f_equal, fexp_negligible_exp_eq... +omega. +(* x <> 0 *) +apply f_equal; unfold canonic_exp, FLT_exp. +apply Z.max_r. +assert (ln_beta beta x-1 < emin+prec)%Z;[idtac|omega]. +destruct (ln_beta beta x) as (e,He); simpl. +apply lt_bpow with beta. +apply Rle_lt_trans with (2:=Hx). +now apply He. +Qed. + +Theorem ulp_FLT_le: forall x, (bpow (emin+prec) <= Rabs x)%R -> + (ulp beta FLT_exp x <= Rabs x * bpow (1-prec))%R. +Proof. +intros x Hx. +assert (x <> 0)%R. +intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt. +rewrite Z, Rabs_R0; apply bpow_gt_0. +rewrite ulp_neq_0; try assumption. +unfold canonic_exp, FLT_exp. +destruct (ln_beta beta x) as (e,He). +apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R. +rewrite <- bpow_plus. +right; apply f_equal. +apply trans_eq with (e-prec)%Z;[idtac|ring]. +simpl; apply Z.max_l. +assert (emin+prec <= e)%Z; try omega. +apply le_bpow with beta. +apply Rle_trans with (1:=Hx). +left; now apply He. +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply He. +Qed. + + +Theorem ulp_FLT_ge: forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0. +rewrite Rabs_R0; apply bpow_gt_0. +rewrite ulp_neq_0; try exact Hx. +unfold canonic_exp, FLT_exp. +apply Rlt_le_trans with (bpow (ln_beta beta x)*bpow (-prec))%R. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +now apply bpow_ln_beta_gt. +rewrite <- bpow_plus. +apply bpow_le. +apply Z.le_max_l. +Qed. + + + (** FLT is a nice format: it has a monotone exponent... *) Global Instance FLT_exp_monotone : Monotone_exp FLT_exp. Proof. diff --git a/flocq/Core/Fcore_FLX.v b/flocq/Core/Fcore_FLX.v index 800540f2..55f6db61 100644 --- a/flocq/Core/Fcore_FLX.v +++ b/flocq/Core/Fcore_FLX.v @@ -24,6 +24,7 @@ Require Import Fcore_rnd. Require Import Fcore_generic_fmt. Require Import Fcore_float_prop. Require Import Fcore_FIX. +Require Import Fcore_ulp. Require Import Fcore_rnd_ne. Section RND_FLX. @@ -211,6 +212,43 @@ now apply FLXN_format_generic. now apply generic_format_FLXN. Qed. +Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R. +Proof. +unfold ulp; rewrite Req_bool_true; trivial. +case (negligible_exp_spec FLX_exp). +intros _; reflexivity. +intros n H2; contradict H2. +unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega. +Qed. + +Theorem ulp_FLX_le: forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLX_0, Rabs_R0. +right; ring. +rewrite ulp_neq_0; try exact Hx. +unfold canonic_exp, FLX_exp. +replace (ln_beta beta x - prec)%Z with ((ln_beta beta x - 1) + (1-prec))%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply bpow_ln_beta_le. +Qed. + + +Theorem ulp_FLX_ge: forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLX_0, Rabs_R0. +right; ring. +rewrite ulp_neq_0; try exact Hx. +unfold canonic_exp, FLX_exp. +unfold Zminus; rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +left; now apply bpow_ln_beta_gt. +Qed. + (** FLX is a nice format: it has a monotone exponent... *) Global Instance FLX_exp_monotone : Monotone_exp FLX_exp. Proof. diff --git a/flocq/Core/Fcore_FTZ.v b/flocq/Core/Fcore_FTZ.v index 5f3e5337..2ebc7851 100644 --- a/flocq/Core/Fcore_FTZ.v +++ b/flocq/Core/Fcore_FTZ.v @@ -23,6 +23,7 @@ Require Import Fcore_defs. Require Import Fcore_rnd. Require Import Fcore_generic_fmt. Require Import Fcore_float_prop. +Require Import Fcore_ulp. Require Import Fcore_FLX. Section RND_FTZ. @@ -182,7 +183,6 @@ Theorem FTZ_format_FLXN : (bpow (emin + prec - 1) <= Rabs x)%R -> FLXN_format beta prec x -> FTZ_format x. Proof. -clear prec_gt_0_. intros x Hx Fx. apply FTZ_format_generic. apply generic_format_FLXN in Fx. @@ -195,6 +195,21 @@ apply Zle_refl. omega. Qed. +Theorem ulp_FTZ_0: ulp beta FTZ_exp 0 = bpow (emin+prec-1). +Proof with auto with typeclass_instances. +unfold ulp; rewrite Req_bool_true; trivial. +case (negligible_exp_spec FTZ_exp). +intros T; specialize (T (emin-1)%Z); contradict T. +apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_. +rewrite Zlt_bool_true; omega. +assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z). +unfold FTZ_exp; rewrite Zlt_bool_true; omega. +intros n H2; rewrite <-V. +apply f_equal, fexp_negligible_exp_eq... +omega. +Qed. + + Section FTZ_round. (** Rounding with FTZ *) diff --git a/flocq/Core/Fcore_Raux.v b/flocq/Core/Fcore_Raux.v index 3758324f..d728e0ba 100644 --- a/flocq/Core/Fcore_Raux.v +++ b/flocq/Core/Fcore_Raux.v @@ -207,6 +207,27 @@ rewrite 3!(Rmult_comm r). now apply Rmult_min_distr_r. Qed. +Lemma Rmin_opp: forall x y, (Rmin (-x) (-y) = - Rmax x y)%R. +Proof. +intros x y. +apply Rmax_case_strong; intros H. +rewrite Rmin_left; trivial. +now apply Ropp_le_contravar. +rewrite Rmin_right; trivial. +now apply Ropp_le_contravar. +Qed. + +Lemma Rmax_opp: forall x y, (Rmax (-x) (-y) = - Rmin x y)%R. +Proof. +intros x y. +apply Rmin_case_strong; intros H. +rewrite Rmax_left; trivial. +now apply Ropp_le_contravar. +rewrite Rmax_right; trivial. +now apply Ropp_le_contravar. +Qed. + + Theorem exp_le : forall x y : R, (x <= y)%R -> (exp x <= exp y)%R. @@ -1930,6 +1951,16 @@ destruct (ln_beta x) as (ex, Ex) ; simpl. now apply Ex. Qed. +Theorem bpow_ln_beta_le : + forall x, (x <> 0)%R -> + (bpow (ln_beta x-1) <= Rabs x)%R. +Proof. +intros x Hx. +destruct (ln_beta x) as (ex, Ex) ; simpl. +now apply Ex. +Qed. + + Theorem ln_beta_le_Zpower : forall m e, m <> Z0 -> @@ -2306,6 +2337,160 @@ Qed. End cond_Ropp. + +(** LPO taken from Coquelicot *) + +Theorem LPO_min : + forall P : nat -> Prop, (forall n, P n \/ ~ P n) -> + {n : nat | P n /\ forall i, (i < n)%nat -> ~ P i} + {forall n, ~ P n}. +Proof. +assert (Hi: forall n, (0 < INR n + 1)%R). + intros N. + rewrite <- S_INR. + apply lt_0_INR. + apply lt_0_Sn. +intros P HP. +set (E y := exists n, (P n /\ y = / (INR n + 1))%R \/ (~ P n /\ y = 0)%R). +assert (HE: forall n, P n -> E (/ (INR n + 1))%R). + intros n Pn. + exists n. + left. + now split. +assert (BE: is_upper_bound E 1). + intros x [y [[_ ->]|[_ ->]]]. + rewrite <- Rinv_1 at 2. + apply Rinv_le. + exact Rlt_0_1. + rewrite <- S_INR. + apply (le_INR 1), le_n_S, le_0_n. + exact Rle_0_1. +destruct (completeness E) as [l [ub lub]]. + now exists 1%R. + destruct (HP O) as [H0|H0]. + exists 1%R. + exists O. + left. + apply (conj H0). + rewrite Rplus_0_l. + apply sym_eq, Rinv_1. + exists 0%R. + exists O. + right. + now split. +destruct (Rle_lt_dec l 0) as [Hl|Hl]. + right. + intros n Pn. + apply Rle_not_lt with (1 := Hl). + apply Rlt_le_trans with (/ (INR n + 1))%R. + now apply Rinv_0_lt_compat. + apply ub. + now apply HE. +left. +set (N := Zabs_nat (up (/l) - 2)). +exists N. +assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). + unfold N. + rewrite INR_IZR_INZ. + rewrite inj_Zabs_nat. + replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. + apply (f_equal (fun v => IZR v + 1)%R). + apply Zabs_eq. + apply Zle_minus_le_0. + apply (Zlt_le_succ 1). + apply lt_IZR. + apply Rle_lt_trans with (/l)%R. + apply Rmult_le_reg_r with (1 := Hl). + rewrite Rmult_1_l, Rinv_l by now apply Rgt_not_eq. + apply lub. + exact BE. + apply archimed. + rewrite minus_IZR. + simpl. + ring. +assert (H: forall i, (i < N)%nat -> ~ P i). + intros i HiN Pi. + unfold is_upper_bound in ub. + refine (Rle_not_lt _ _ (ub (/ (INR i + 1))%R _) _). + now apply HE. + rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. + apply Rinv_1_lt_contravar. + rewrite <- S_INR. + apply (le_INR 1). + apply le_n_S. + apply le_0_n. + apply Rlt_le_trans with (INR N + 1)%R. + apply Rplus_lt_compat_r. + now apply lt_INR. + rewrite HN. + apply Rplus_le_reg_r with (-/l + 1)%R. + ring_simplify. + apply archimed. +destruct (HP N) as [PN|PN]. + now split. +elimtype False. +refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _). + intros x [y [[Py ->]|[_ ->]]]. + destruct (eq_nat_dec y N) as [HyN|HyN]. + elim PN. + now rewrite <- HyN. + apply Rinv_le. + apply Hi. + apply Rplus_le_compat_r. + apply Rnot_lt_le. + intros Hy. + refine (H _ _ Py). + apply INR_lt in Hy. + clear -Hy HyN. + omega. + now apply Rlt_le, Rinv_0_lt_compat. +rewrite S_INR, HN. +ring_simplify (IZR (up (/ l)) - 1 + 1)%R. +rewrite <- (Rinv_involutive l) at 2 by now apply Rgt_not_eq. +apply Rinv_1_lt_contravar. +rewrite <- Rinv_1. +apply Rinv_le. +exact Hl. +now apply lub. +apply archimed. +Qed. + +Theorem LPO : + forall P : nat -> Prop, (forall n, P n \/ ~ P n) -> + {n : nat | P n} + {forall n, ~ P n}. +Proof. +intros P HP. +destruct (LPO_min P HP) as [[n [Pn _]]|Pn]. +left. +now exists n. +now right. +Qed. + + +Lemma LPO_Z : forall P : Z -> Prop, (forall n, P n \/ ~P n) -> + {n : Z| P n} + {forall n, ~ P n}. +Proof. +intros P H. +destruct (LPO (fun n => P (Z.of_nat n))) as [J|J]. +intros n; apply H. +destruct J as (n, Hn). +left; now exists (Z.of_nat n). +destruct (LPO (fun n => P (-Z.of_nat n)%Z)) as [K|K]. +intros n; apply H. +destruct K as (n, Hn). +left; now exists (-Z.of_nat n)%Z. +right; intros n; case (Zle_or_lt 0 n); intros M. +rewrite <- (Zabs_eq n); trivial. +rewrite <- Zabs2Nat.id_abs. +apply J. +rewrite <- (Zopp_involutive n). +rewrite <- (Z.abs_neq n). +rewrite <- Zabs2Nat.id_abs. +apply K. +omega. +Qed. + + + (** A little tactic to simplify terms of the form [bpow a * bpow b]. *) Ltac bpow_simplify := (* bpow ex * bpow ey ~~> bpow (ex + ey) *) diff --git a/flocq/Core/Fcore_Zaux.v b/flocq/Core/Fcore_Zaux.v index 4702d62e..f6731b4c 100644 --- a/flocq/Core/Fcore_Zaux.v +++ b/flocq/Core/Fcore_Zaux.v @@ -927,3 +927,65 @@ intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy. Qed. End faster_div. + +Section Iter. + +Context {A : Type}. +Variable (f : A -> A). + +Fixpoint iter_nat (n : nat) (x : A) {struct n} : A := + match n with + | S n' => iter_nat n' (f x) + | O => x + end. + +Lemma iter_nat_plus : + forall (p q : nat) (x : A), + iter_nat (p + q) x = iter_nat p (iter_nat q x). +Proof. +induction q. +now rewrite plus_0_r. +intros x. +rewrite <- plus_n_Sm. +apply IHq. +Qed. + +Lemma iter_nat_S : + forall (p : nat) (x : A), + iter_nat (S p) x = f (iter_nat p x). +Proof. +induction p. +easy. +simpl. +intros x. +apply IHp. +Qed. + +Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := + match n with + | xI n' => iter_pos n' (iter_pos n' (f x)) + | xO n' => iter_pos n' (iter_pos n' x) + | xH => f x + end. + +Lemma iter_pos_nat : + forall (p : positive) (x : A), + iter_pos p x = iter_nat (Pos.to_nat p) x. +Proof. +induction p ; intros x. +rewrite Pos2Nat.inj_xI. +simpl. +rewrite plus_0_r. +rewrite iter_nat_plus. +rewrite (IHp (f x)). +apply IHp. +rewrite Pos2Nat.inj_xO. +simpl. +rewrite plus_0_r. +rewrite iter_nat_plus. +rewrite (IHp x). +apply IHp. +easy. +Qed. + +End Iter. diff --git a/flocq/Core/Fcore_digits.v b/flocq/Core/Fcore_digits.v index 13174d29..d40c1a09 100644 --- a/flocq/Core/Fcore_digits.v +++ b/flocq/Core/Fcore_digits.v @@ -21,7 +21,7 @@ Require Import ZArith. Require Import Zquot. Require Import Fcore_Zaux. -(** Computes the number of bits (radix 2) of a positive integer. +(** Number of bits (radix 2) of a positive integer. It serves as an upper bound on the number of digits to ensure termination. *) @@ -466,6 +466,8 @@ now apply Hd. now rewrite 3!Zdigit_lt. Qed. +(** Left and right shifts *) + Definition Zscale n k := if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)). @@ -545,6 +547,8 @@ rewrite Zle_bool_true with (1 := Hk). now apply Zscale_mul_pow. Qed. +(** Slice of an integer *) + Definition Zslice n k1 k2 := if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0. @@ -756,6 +760,7 @@ Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z := End digits_aux. (** Number of digits of an integer *) + Definition Zdigits n := match n with | Z0 => Z0 @@ -1011,7 +1016,7 @@ generalize (Zpower_gt_Zdigits e x). omega. Qed. -(** Characterizes the number digits of a product. +(** Number of digits of a product. This strong version is needed for proofs of division and square root algorithms, since they involve operation remainders. @@ -1126,6 +1131,8 @@ Qed. End Fcore_digits. +(** Specialized version for computing the number of bits of an integer *) + Section Zdigits2. Theorem Z_of_nat_S_digits2_Pnat : diff --git a/flocq/Core/Fcore_float_prop.v b/flocq/Core/Fcore_float_prop.v index e1535bc9..8199ede6 100644 --- a/flocq/Core/Fcore_float_prop.v +++ b/flocq/Core/Fcore_float_prop.v @@ -233,6 +233,37 @@ rewrite <- F2R_0 with (Fexp f). now apply F2R_lt_compat. Qed. +Theorem F2R_neq_0_compat : + forall f : float beta, + (Fnum f <> 0)%Z -> + (F2R f <> 0)%R. +Proof. +intros f H H1. +apply H. +now apply F2R_eq_0_reg with (Fexp f). +Qed. + + +Lemma Fnum_ge_0_compat: forall (f : float beta), + (0 <= F2R f)%R -> (0 <= Fnum f)%Z. +Proof. +intros f H. +case (Zle_or_lt 0 (Fnum f)); trivial. +intros H1; contradict H. +apply Rlt_not_le. +now apply F2R_lt_0_compat. +Qed. + +Lemma Fnum_le_0_compat: forall (f : float beta), + (F2R f <= 0)%R -> (Fnum f <= 0)%Z. +Proof. +intros f H. +case (Zle_or_lt (Fnum f) 0); trivial. +intros H1; contradict H. +apply Rlt_not_le. +now apply F2R_gt_0_compat. +Qed. + (** Floats and bpow *) Theorem F2R_bpow : forall e : Z, diff --git a/flocq/Core/Fcore_generic_fmt.v b/flocq/Core/Fcore_generic_fmt.v index 45729f2a..bac65b9d 100644 --- a/flocq/Core/Fcore_generic_fmt.v +++ b/flocq/Core/Fcore_generic_fmt.v @@ -1015,7 +1015,7 @@ Qed. End monotone. -Theorem round_abs_abs' : +Theorem round_abs_abs : forall P : R -> R -> Prop, ( forall rnd (Hr : Valid_rnd rnd) x, (0 <= x)%R -> P x (round rnd x) ) -> forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)). @@ -1043,18 +1043,6 @@ apply round_le... now apply Rlt_le. Qed. -(* TODO: remove *) -Theorem round_abs_abs : - forall P : R -> R -> Prop, - ( forall rnd (Hr : Valid_rnd rnd) x, P x (round rnd x) ) -> - forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)). -Proof. -intros P HP. -apply round_abs_abs'. -intros. -now apply HP. -Qed. - Theorem round_bounded_large : forall rnd {Hr : Valid_rnd rnd} x ex, (fexp ex < ex)%Z -> @@ -1064,7 +1052,7 @@ Proof with auto with typeclass_instances. intros rnd Hr x ex He. apply round_abs_abs... clear rnd Hr x. -intros rnd' Hr x. +intros rnd' Hr x _. apply round_bounded_large_pos... Qed. @@ -1076,7 +1064,7 @@ Proof. intros rnd Hr x ex H1 H2. generalize Rabs_R0. rewrite <- H2 at 1. -apply (round_abs_abs' (fun t rt => forall (ex : Z), +apply (round_abs_abs (fun t rt => forall (ex : Z), (bpow (ex - 1) <= t < bpow ex)%R -> rt = 0%R -> (ex <= fexp ex)%Z)); trivial. clear; intros rnd Hr x Hx. @@ -1496,7 +1484,7 @@ right. now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He). Qed. -Theorem ln_beta_round_DN : +Theorem ln_beta_DN : forall x, (0 < round Zfloor x)%R -> (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z). @@ -1513,7 +1501,6 @@ now apply Rgt_not_eq. now apply Rlt_le. Qed. -(* TODO: remove *) Theorem canonic_exp_DN : forall x, (0 < round Zfloor x)%R -> @@ -1521,7 +1508,7 @@ Theorem canonic_exp_DN : Proof. intros x Hd. apply (f_equal fexp). -now apply ln_beta_round_DN. +now apply ln_beta_DN. Qed. Theorem scaled_mantissa_DN : @@ -2312,7 +2299,7 @@ intros x Gx. apply generic_format_abs_inv. apply generic_format_abs in Gx. revert rnd valid_rnd x Gx. -refine (round_abs_abs' _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _). +refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _). intros rnd valid_rnd x [Hx|Hx] Gx. (* x > 0 *) generalize (ln_beta_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx). diff --git a/flocq/Core/Fcore_rnd.v b/flocq/Core/Fcore_rnd.v index 94c94203..171c27fc 100644 --- a/flocq/Core/Fcore_rnd.v +++ b/flocq/Core/Fcore_rnd.v @@ -39,7 +39,7 @@ exists f. intros g Hg. now apply H2 with (3 := Rle_refl x). (* . *) -exists (projT1 (completeness _ H3 H1)). +exists (proj1_sig (completeness _ H3 H1)). destruct completeness as (f1, (H4, H5)). simpl. destruct H1 as (f2, H1). @@ -58,7 +58,7 @@ Theorem round_fun_of_pred : { f : R -> R | forall x, rnd x (f x) }. Proof. intros rnd H. -exists (fun x => projT1 (round_val_of_pred rnd H x)). +exists (fun x => proj1_sig (round_val_of_pred rnd H x)). intros x. now destruct round_val_of_pred as (f, H1). Qed. diff --git a/flocq/Core/Fcore_rnd_ne.v b/flocq/Core/Fcore_rnd_ne.v index 6829c0c8..1f265406 100644 --- a/flocq/Core/Fcore_rnd_ne.v +++ b/flocq/Core/Fcore_rnd_ne.v @@ -164,7 +164,7 @@ now apply Rlt_le. assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp. assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R). rewrite Hxu, Hxd. -now apply ulp_DN_UP. +now apply round_UP_DN_ulp. destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2]. (* - xu > bpow ex *) elim (Rlt_not_le _ _ Hu2). @@ -191,7 +191,8 @@ rewrite Rmult_plus_distr_r. rewrite Z2R_Zpower, <- bpow_plus. ring_simplify (ex - fexp ex + fexp ex)%Z. rewrite Hu2, Hud. -unfold ulp, canonic_exp. +rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. +unfold canonic_exp. rewrite ln_beta_unique with beta x ex. unfold F2R. simpl. ring. @@ -223,7 +224,8 @@ specialize (H ex). omega. (* - xu < bpow ex *) revert Hud. -unfold ulp, F2R. +rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. +unfold F2R. rewrite Hd, Hu. unfold canonic_exp. rewrite ln_beta_unique with beta (F2R xu) ex. diff --git a/flocq/Core/Fcore_ulp.v b/flocq/Core/Fcore_ulp.v index 04bed01c..1c27de31 100644 --- a/flocq/Core/Fcore_ulp.v +++ b/flocq/Core/Fcore_ulp.v @@ -32,9 +32,79 @@ Notation bpow e := (bpow beta e). Variable fexp : Z -> Z. +(** Definition and basic properties about the minimal exponent, when it exists *) + +Lemma Z_le_dec_aux: forall x y : Z, (x <= y)%Z \/ ~ (x <= y)%Z. +intros. +destruct (Z_le_dec x y). +now left. +now right. +Qed. + + +(** [negligible_exp] is either none (as in FLX) or Some n such that n <= fexp n. *) +Definition negligible_exp: option Z := + match (LPO_Z _ (fun z => Z_le_dec_aux z (fexp z))) with + | inleft N => Some (proj1_sig N) + | inright _ => None + end. + + +Inductive negligible_exp_prop: option Z -> Prop := + | negligible_None: (forall n, (fexp n < n)%Z) -> negligible_exp_prop None + | negligible_Some: forall n, (n <= fexp n)%Z -> negligible_exp_prop (Some n). + + +Lemma negligible_exp_spec: negligible_exp_prop negligible_exp. +Proof. +unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. +now apply negligible_Some. +apply negligible_None. +intros n; specialize (Hn n); omega. +Qed. + +Lemma negligible_exp_spec': (negligible_exp = None /\ forall n, (fexp n < n)%Z) + \/ exists n, (negligible_exp = Some n /\ (n <= fexp n)%Z). +Proof. +unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. +right; simpl; exists n; now split. +left; split; trivial. +intros n; specialize (Hn n); omega. +Qed. + Context { valid_exp : Valid_exp fexp }. -Definition ulp x := bpow (canonic_exp beta fexp x). +Lemma fexp_negligible_exp_eq: forall n m, (n <= fexp n)%Z -> (m <= fexp m)%Z -> fexp n = fexp m. +Proof. +intros n m Hn Hm. +case (Zle_or_lt n m); intros H. +apply valid_exp; omega. +apply sym_eq, valid_exp; omega. +Qed. + + +(** Definition and basic properties about the ulp *) +(** Now includes a nice ulp(0): ulp(0) is now 0 when there is no minimal + exponent, such as in FLX, and beta^(fexp n) when there is a n such + that n <= fexp n. For instance, the value of ulp(O) is then + beta^emin in FIX and FLT. The main lemma to use is ulp_neq_0 that + is equivalent to the previous "unfold ulp" provided the value is + not zero. *) + +Definition ulp x := match Req_bool x 0 with + | true => match negligible_exp with + | Some n => bpow (fexp n) + | None => 0%R + end + | false => bpow (canonic_exp beta fexp x) + end. + +Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x). +Proof. +intros x Hx. +unfold ulp; case (Req_bool_spec x); trivial. +intros H; now contradict H. +Qed. Notation F := (generic_format beta fexp). @@ -43,17 +113,37 @@ Theorem ulp_opp : Proof. intros x. unfold ulp. +case Req_bool_spec; intros H1. +rewrite Req_bool_true; trivial. +rewrite <- (Ropp_involutive x), H1; ring. +rewrite Req_bool_false. now rewrite canonic_exp_opp. +intros H2; apply H1; rewrite H2; ring. Qed. Theorem ulp_abs : forall x, ulp (Rabs x) = ulp x. Proof. intros x. -unfold ulp. +unfold ulp; case (Req_bool_spec x 0); intros H1. +rewrite Req_bool_true; trivial. +now rewrite H1, Rabs_R0. +rewrite Req_bool_false. now rewrite canonic_exp_abs. +now apply Rabs_no_R0. Qed. +Theorem ulp_ge_0: + forall x, (0 <= ulp x)%R. +Proof. +intros x; unfold ulp; case Req_bool_spec; intros. +case negligible_exp; intros. +apply bpow_ge_0. +apply Rle_refl. +apply bpow_ge_0. +Qed. + + Theorem ulp_le_id: forall x, (0 < x)%R -> @@ -63,7 +153,9 @@ Proof. intros x Zx Fx. rewrite <- (Rmult_1_l (ulp x)). pattern x at 2; rewrite Fx. -unfold F2R, ulp; simpl. +rewrite ulp_neq_0. +2: now apply Rgt_not_eq. +unfold F2R; simpl. apply Rmult_le_compat_r. apply bpow_ge_0. replace 1%R with (Z2R (Zsucc 0)) by reflexivity. @@ -86,12 +178,15 @@ now apply Rabs_pos_lt. now apply generic_format_abs. Qed. -Theorem ulp_DN_UP : + +(* was ulp_DN_UP *) +Theorem round_UP_DN_ulp : forall x, ~ F x -> round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R. Proof. intros x Fx. -unfold round, ulp. simpl. +rewrite ulp_neq_0. +unfold round. simpl. unfold F2R. simpl. rewrite Zceil_floor_neq. rewrite Z2R_plus. simpl. @@ -103,459 +198,233 @@ rewrite <- H. rewrite Ztrunc_Z2R. rewrite H. now rewrite scaled_mantissa_mult_bpow. +intros V; apply Fx. +rewrite V. +apply generic_format_0. Qed. -(** The successor of x is x + ulp x *) -Theorem succ_le_bpow : - forall x e, (0 < x)%R -> F x -> - (x < bpow e)%R -> - (x + ulp x <= bpow e)%R. -Proof. -intros x e Zx Fx Hx. -pattern x at 1 ; rewrite Fx. -unfold ulp, F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. -rewrite <- Rmult_plus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_plus. -change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R. -apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -now rewrite <- Fx. -Qed. -Theorem ln_beta_succ : - forall x, (0 < x)%R -> F x -> - forall eps, (0 <= eps < ulp x)%R -> - ln_beta beta (x + eps) = ln_beta beta x :> Z. -Proof. -intros x Zx Fx eps Heps. -destruct (ln_beta beta x) as (ex, He). -simpl. -specialize (He (Rgt_not_eq _ _ Zx)). -apply ln_beta_unique. +Theorem ulp_bpow : + forall e, ulp (bpow e) = bpow (fexp (e + 1)). +intros e. +rewrite ulp_neq_0. +apply f_equal. +apply canonic_exp_fexp. rewrite Rabs_pos_eq. -rewrite Rabs_pos_eq in He. split. -apply Rle_trans with (1 := proj1 He). -pattern x at 1 ; rewrite <- Rplus_0_r. -now apply Rplus_le_compat_l. -apply Rlt_le_trans with (x + ulp x)%R. -now apply Rplus_lt_compat_l. -pattern x at 1 ; rewrite Fx. -unfold ulp, F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. -rewrite <- Rmult_plus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_plus. -change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R. -apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -now rewrite <- Fx. -now apply Rlt_le. -apply Rplus_le_le_0_compat. -now apply Rlt_le. -apply Heps. +ring_simplify (e + 1 - 1)%Z. +apply Rle_refl. +apply bpow_lt. +apply Zlt_succ. +apply bpow_ge_0. +apply Rgt_not_eq, Rlt_gt, bpow_gt_0. Qed. -Theorem round_DN_succ : - forall x, (0 < x)%R -> F x -> - forall eps, (0 <= eps < ulp x)%R -> - round beta fexp Zfloor (x + eps) = x. + +Lemma generic_format_ulp_0: + F (ulp 0). Proof. -intros x Zx Fx eps Heps. -pattern x at 2 ; rewrite Fx. -unfold round. -unfold scaled_mantissa. simpl. -unfold canonic_exp at 1 2. -rewrite ln_beta_succ ; trivial. -apply (f_equal (fun m => F2R (Float beta m _))). -rewrite Ztrunc_floor. -apply Zfloor_imp. -split. -apply (Rle_trans _ _ _ (Zfloor_lb _)). -apply Rmult_le_compat_r. -apply bpow_ge_0. -pattern x at 1 ; rewrite <- Rplus_0_r. -now apply Rplus_le_compat_l. -apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -now apply Rplus_lt_compat_l. -rewrite Rmult_plus_distr_r. -rewrite Z2R_plus. -apply Rplus_le_compat. -pattern x at 1 3 ; rewrite Fx. -unfold F2R. simpl. -rewrite Rmult_assoc. -rewrite <- bpow_plus. -rewrite Zplus_opp_r. -rewrite Rmult_1_r. -rewrite Zfloor_Z2R. -apply Rle_refl. unfold ulp. -rewrite <- bpow_plus. -rewrite Zplus_opp_r. -apply Rle_refl. -apply Rmult_le_pos. -now apply Rlt_le. -apply bpow_ge_0. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros _; apply generic_format_0. +intros n H1. +apply generic_format_bpow. +now apply valid_exp. Qed. -Theorem generic_format_succ : - forall x, (0 < x)%R -> F x -> - F (x + ulp x). +Lemma generic_format_bpow_ge_ulp_0: forall e, + (ulp 0 <= bpow e)%R -> F (bpow e). Proof. -intros x Zx Fx. -destruct (ln_beta beta x) as (ex, Ex). -specialize (Ex (Rgt_not_eq _ _ Zx)). -assert (Ex' := Ex). -rewrite Rabs_pos_eq in Ex'. -destruct (succ_le_bpow x ex) ; try easy. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_unique with beta (x + ulp x)%R ex. -pattern x at 1 3 ; rewrite Fx. -unfold ulp, scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). -unfold F2R. simpl. -rewrite Rmult_plus_distr_r. -rewrite Rmult_assoc. -rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. -change (bpow 0) with (Z2R 1). -rewrite <- Z2R_plus. -rewrite Ztrunc_Z2R. -rewrite Z2R_plus. -rewrite Rmult_plus_distr_r. -now rewrite Rmult_1_l. -rewrite Rabs_pos_eq. -split. -apply Rle_trans with (1 := proj1 Ex'). -pattern x at 1 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -apply bpow_ge_0. -exact H. -apply Rplus_le_le_0_compat. -now apply Rlt_le. -apply bpow_ge_0. -rewrite H. +intros e; unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros H1 _. apply generic_format_bpow. -apply valid_exp. -destruct (Zle_or_lt ex (fexp ex)) ; trivial. -elim Rlt_not_le with (1 := Zx). -rewrite Fx. -replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0. -rewrite F2R_0. -apply Rle_refl. -unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). -destruct (mantissa_small_pos beta fexp x ex) ; trivial. -rewrite Ztrunc_floor. -apply sym_eq. -apply Zfloor_imp. -split. -now apply Rlt_le. -exact H2. -now apply Rlt_le. -now apply Rlt_le. +specialize (H1 (e+1)%Z); omega. +intros n H1 H2. +apply generic_format_bpow. +case (Zle_or_lt (e+1) (fexp (e+1))); intros H4. +absurd (e+1 <= e)%Z. +omega. +apply Zle_trans with (1:=H4). +replace (fexp (e+1)) with (fexp n). +now apply le_bpow with beta. +now apply fexp_negligible_exp_eq. +omega. Qed. -Theorem round_UP_succ : - forall x, (0 < x)%R -> F x -> - forall eps, (0 < eps <= ulp x)%R -> - round beta fexp Zceil (x + eps) = (x + ulp x)%R. -Proof with auto with typeclass_instances. -intros x Zx Fx eps (Heps1,[Heps2|Heps2]). -assert (Heps: (0 <= eps < ulp x)%R). -split. -now apply Rlt_le. -exact Heps2. -assert (Hd := round_DN_succ x Zx Fx eps Heps). -rewrite ulp_DN_UP. -rewrite Hd. -unfold ulp, canonic_exp. -now rewrite ln_beta_succ. -intros Fs. -rewrite round_generic in Hd... -apply Rgt_not_eq with (2 := Hd). -pattern x at 2 ; rewrite <- Rplus_0_r. -now apply Rplus_lt_compat_l. -rewrite Heps2. -apply round_generic... -now apply generic_format_succ. +(** The three following properties are equivalent: + [Exp_not_FTZ] ; forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *) + +Lemma generic_format_ulp: Exp_not_FTZ fexp -> + forall x, F (ulp x). +Proof. +unfold Exp_not_FTZ; intros H x. +case (Req_dec x 0); intros Hx. +rewrite Hx; apply generic_format_ulp_0. +rewrite (ulp_neq_0 _ Hx). +apply generic_format_bpow; unfold canonic_exp. +apply H. Qed. -Theorem succ_le_lt: - forall x y, - F x -> F y -> - (0 < x < y)%R -> - (x + ulp x <= y)%R. -Proof with auto with typeclass_instances. -intros x y Hx Hy H. -case (Rle_or_lt (ulp x) (y-x)); intros H1. -apply Rplus_le_reg_r with (-x)%R. -now ring_simplify (x+ulp x + -x)%R. -replace y with (x+(y-x))%R by ring. -absurd (x < y)%R. -2: apply H. -apply Rle_not_lt; apply Req_le. -rewrite <- round_DN_succ with (eps:=(y-x)%R); try easy. -ring_simplify (x+(y-x))%R. -apply sym_eq. -apply round_generic... -split; trivial. -apply Rlt_le; now apply Rlt_Rminus. +Lemma not_FTZ_generic_format_ulp: + (forall x, F (ulp x)) -> Exp_not_FTZ fexp. +intros H e. +specialize (H (bpow (e-1))). +rewrite ulp_neq_0 in H. +2: apply Rgt_not_eq, bpow_gt_0. +unfold canonic_exp in H. +rewrite ln_beta_bpow in H. +apply generic_format_bpow_inv' in H... +now replace (e-1+1)%Z with e in H by ring. Qed. -(** Error of a rounding, expressed in number of ulps *) -Theorem ulp_error : - forall rnd { Zrnd : Valid_rnd rnd } x, - (Rabs (round beta fexp rnd x - x) < ulp x)%R. -Proof with auto with typeclass_instances. -intros rnd Zrnd x. -destruct (generic_format_EM beta fexp x) as [Hx|Hx]. -(* x = rnd x *) -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -apply bpow_gt_0. -(* x <> rnd x *) -destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H. -(* . *) -rewrite Rabs_left1. -rewrite Ropp_minus_distr. -apply Rplus_lt_reg_l with (round beta fexp Zfloor x). -rewrite <- ulp_DN_UP with (1 := Hx). -ring_simplify. -assert (Hu: (x <= round beta fexp Zceil x)%R). -apply round_UP_pt... -destruct Hu as [Hu|Hu]. -exact Hu. -elim Hx. -rewrite Hu. -apply generic_format_round... -apply Rle_minus. -apply round_DN_pt... -(* . *) -rewrite Rabs_pos_eq. -rewrite ulp_DN_UP with (1 := Hx). -apply Rplus_lt_reg_r with (x - ulp x)%R. -ring_simplify. -assert (Hd: (round beta fexp Zfloor x <= x)%R). -apply round_DN_pt... -destruct Hd as [Hd|Hd]. -exact Hd. -elim Hx. -rewrite <- Hd. -apply generic_format_round... -apply Rle_0_minus. -apply round_UP_pt... + +Lemma ulp_ge_ulp_0: Exp_not_FTZ fexp -> + forall x, (ulp 0 <= ulp x)%R. +Proof. +unfold Exp_not_FTZ; intros H x. +case (Req_dec x 0); intros Hx. +rewrite Hx; now right. +unfold ulp at 1. +rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +intros (H1,H2); rewrite H1; apply ulp_ge_0. +intros (n,(H1,H2)); rewrite H1. +rewrite ulp_neq_0; trivial. +apply bpow_le; unfold canonic_exp. +generalize (ln_beta beta x); intros l. +case (Zle_or_lt l (fexp l)); intros Hl. +rewrite (fexp_negligible_exp_eq n l); trivial; apply Zle_refl. +case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K. +absurd (fexp n <= fexp l)%Z. +omega. +apply Zle_trans with (2:= H _). +apply Zeq_le, sym_eq, valid_exp; trivial. +omega. Qed. -Theorem ulp_half_error : - forall choice x, - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R. -Proof with auto with typeclass_instances. -intros choice x. -destruct (generic_format_EM beta fexp x) as [Hx|Hx]. -(* x = rnd x *) -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -apply Rmult_le_pos. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_ge_0. -(* x <> rnd x *) -set (d := round beta fexp Zfloor x). -destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2). -destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H]. -(* . rnd(x) = rndd(x) *) -apply Rle_trans with (Rabs (d - x)). -apply Hr2. -apply (round_DN_pt beta fexp x). -rewrite Rabs_left1. -rewrite Ropp_minus_distr. -apply Rmult_le_reg_r with 2%R. -now apply (Z2R_lt 0 2). -apply Rplus_le_reg_r with (d - x)%R. -ring_simplify. -apply Rle_trans with (1 := H). -right. field. -apply Rle_minus. -apply (round_DN_pt beta fexp x). -(* . rnd(x) = rndu(x) *) -assert (Hu: (d + ulp x)%R = round beta fexp Zceil x). -unfold d. -now rewrite <- ulp_DN_UP. -apply Rle_trans with (Rabs (d + ulp x - x)). -apply Hr2. -rewrite Hu. -apply (round_UP_pt beta fexp x). -rewrite Rabs_pos_eq. -apply Rmult_le_reg_r with 2%R. -now apply (Z2R_lt 0 2). -apply Rplus_le_reg_r with (- (d + ulp x - x))%R. -ring_simplify. -apply Rlt_le. -apply Rlt_le_trans with (1 := H). -right. field. -apply Rle_0_minus. -rewrite Hu. -apply (round_UP_pt beta fexp x). +Lemma not_FTZ_ulp_ge_ulp_0: + (forall x, (ulp 0 <= ulp x)%R) -> Exp_not_FTZ fexp. +Proof. +intros H e. +apply generic_format_bpow_inv' with beta. +apply generic_format_bpow_ge_ulp_0. +replace e with ((e-1)+1)%Z by ring. +rewrite <- ulp_bpow. +apply H. Qed. -Theorem ulp_le : + + +Theorem ulp_le_pos : forall { Hm : Monotone_exp fexp }, forall x y: R, - (0 < x)%R -> (x <= y)%R -> + (0 <= x)%R -> (x <= y)%R -> (ulp x <= ulp y)%R. -Proof. +Proof with auto with typeclass_instances. intros Hm x y Hx Hxy. +destruct Hx as [Hx|Hx]. +rewrite ulp_neq_0. +rewrite ulp_neq_0. apply bpow_le. apply Hm. now apply ln_beta_le. +apply Rgt_not_eq, Rlt_gt. +now apply Rlt_le_trans with (1:=Hx). +now apply Rgt_not_eq. +rewrite <- Hx. +apply ulp_ge_ulp_0. +apply monotone_exp_not_FTZ... Qed. -Theorem ulp_bpow : - forall e, ulp (bpow e) = bpow (fexp (e + 1)). -intros e. -unfold ulp. -apply f_equal. -apply canonic_exp_fexp. -rewrite Rabs_pos_eq. -split. -ring_simplify (e + 1 - 1)%Z. -apply Rle_refl. -apply bpow_lt. -apply Zlt_succ. -apply bpow_ge_0. -Qed. -Theorem ulp_DN : - forall x, - (0 < round beta fexp Zfloor x)%R -> - ulp (round beta fexp Zfloor x) = ulp x. +Theorem ulp_le : + forall { Hm : Monotone_exp fexp }, + forall x y: R, + (Rabs x <= Rabs y)%R -> + (ulp x <= ulp y)%R. Proof. -intros x Hd. -unfold ulp. -now rewrite canonic_exp_DN with (2 := Hd). +intros Hm x y Hxy. +rewrite <- ulp_abs. +rewrite <- (ulp_abs y). +apply ulp_le_pos; trivial. +apply Rabs_pos. Qed. -Theorem ulp_error_f : - forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, - (round beta fexp rnd x <> 0)%R -> - (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R. -Proof with auto with typeclass_instances. -intros Hm rnd Zrnd x Hfx. -case (round_DN_or_UP beta fexp rnd x); intros Hx. -(* *) -case (Rle_or_lt 0 (round beta fexp Zfloor x)). -intros H; destruct H. -rewrite Hx at 2. -rewrite ulp_DN; trivial. -apply ulp_error... -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. -apply Rlt_le_trans with (1:=ulp_error _ _). -rewrite <- (ulp_opp x), <- (ulp_opp (round beta fexp rnd x)). -apply ulp_le; trivial. -apply Ropp_0_gt_lt_contravar; apply Rlt_gt. -case (Rle_or_lt 0 x); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_ge_generic... -apply generic_format_0. -apply Ropp_le_contravar; rewrite Hx. -apply (round_DN_pt beta fexp x). -(* *) -rewrite Hx; case (Rle_or_lt 0 (round beta fexp Zceil x)). -intros H; destruct H. -apply Rlt_le_trans with (1:=ulp_error _ _). -apply ulp_le; trivial. -case (Rle_or_lt x 0); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_le_generic... -apply generic_format_0. -apply round_UP_pt... -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. -rewrite <- (ulp_opp (round beta fexp Zceil x)). -rewrite <- round_DN_opp. -rewrite ulp_DN; trivial. -replace (round beta fexp Zceil x - x)%R with (-((round beta fexp Zfloor (-x) - (-x))))%R. -rewrite Rabs_Ropp. -apply ulp_error... -rewrite round_DN_opp; ring. -rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption. -Qed. -Theorem ulp_half_error_f : - forall { Hm : Monotone_exp fexp }, - forall choice x, - (round beta fexp (Znearest choice) x <> 0)%R -> - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros Hm choice x Hfx. -case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx. -(* *) -case (Rle_or_lt 0 (round beta fexp Zfloor x)). -intros H; destruct H. -rewrite Hx at 2. -rewrite ulp_DN; trivial. -apply ulp_half_error. -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. -apply Rle_trans with (1:=ulp_half_error _ _). -apply Rmult_le_compat_l. -auto with real. -rewrite <- (ulp_opp x), <- (ulp_opp (round beta fexp (Znearest choice) x)). -apply ulp_le; trivial. -apply Ropp_0_gt_lt_contravar; apply Rlt_gt. -case (Rle_or_lt 0 x); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_ge_generic... -apply generic_format_0. -apply Ropp_le_contravar; rewrite Hx. -apply (round_DN_pt beta fexp x). -(* *) -case (Rle_or_lt 0 (round beta fexp Zceil x)). -intros H; destruct H. -apply Rle_trans with (1:=ulp_half_error _ _). -apply Rmult_le_compat_l. -auto with real. -apply ulp_le; trivial. -case (Rle_or_lt x 0); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_le_generic... -apply generic_format_0. -rewrite Hx; apply (round_UP_pt beta fexp x). -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. -rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)). -rewrite <- round_DN_opp. -rewrite ulp_DN; trivial. -pattern x at 1 2; rewrite <- Ropp_involutive. -rewrite round_N_opp. -unfold Rminus. -rewrite <- Ropp_plus_distr, Rabs_Ropp. -apply ulp_half_error. -rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption. -Qed. -(** Predecessor *) -Definition pred x := +(** Definition and properties of pred and succ *) + +Definition pred_pos x := if Req_bool x (bpow (ln_beta beta x - 1)) then (x - bpow (fexp (ln_beta beta x - 1)))%R else (x - ulp x)%R. -Theorem pred_ge_bpow : +Definition succ x := + if (Rle_bool 0 x) then + (x+ulp x)%R + else + (- pred_pos (-x))%R. + +Definition pred x := (- succ (-x))%R. + +Theorem pred_eq_pos: + forall x, (0 <= x)%R -> (pred x = pred_pos x)%R. +Proof. +intros x Hx; unfold pred, succ. +case Rle_bool_spec; intros Hx'. +assert (K:(x = 0)%R). +apply Rle_antisym; try assumption. +apply Ropp_le_cancel. +now rewrite Ropp_0. +rewrite K; unfold pred_pos. +rewrite Req_bool_false. +2: apply Rlt_not_eq, bpow_gt_0. +rewrite Ropp_0; ring. +now rewrite 2!Ropp_involutive. +Qed. + +Theorem succ_eq_pos: + forall x, (0 <= x)%R -> (succ x = x + ulp x)%R. +Proof. +intros x Hx; unfold succ. +now rewrite Rle_bool_true. +Qed. + +Lemma pred_eq_opp_succ_opp: forall x, pred x = (- succ (-x))%R. +Proof. +reflexivity. +Qed. + +Lemma succ_eq_opp_pred_opp: forall x, succ x = (- pred (-x))%R. +Proof. +intros x; unfold pred. +now rewrite 2!Ropp_involutive. +Qed. + +Lemma succ_opp: forall x, (succ (-x) = - pred x)%R. +Proof. +intros x; rewrite succ_eq_opp_pred_opp. +now rewrite Ropp_involutive. +Qed. + +Lemma pred_opp: forall x, (pred (-x) = - succ x)%R. +Proof. +intros x; rewrite pred_eq_opp_succ_opp. +now rewrite Ropp_involutive. +Qed. + + + + +(** pred and succ are in the format *) + +(* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *) +(* was pred_ge_bpow *) +Theorem id_m_ulp_ge_bpow : forall x e, F x -> x <> ulp x -> (bpow e < x)%R -> @@ -573,7 +442,8 @@ omega. case (Zle_lt_or_eq _ _ H); intros Hm. (* *) pattern x at 1 ; rewrite Fx. -unfold ulp, F2R. simpl. +rewrite ulp_neq_0. +unfold F2R. simpl. pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. rewrite <- Rmult_minus_distr_r. change 1%R with (Z2R 1). @@ -581,15 +451,44 @@ rewrite <- Z2R_minus. change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R. apply bpow_le_F2R_m1; trivial. now rewrite <- Fx. +apply Rgt_not_eq, Rlt_gt. +apply Rlt_trans with (2:=Hx), bpow_gt_0. (* *) contradict Hx'. pattern x at 1; rewrite Fx. rewrite <- Hm. -unfold ulp, F2R; simpl. +rewrite ulp_neq_0. +unfold F2R; simpl. now rewrite Rmult_1_l. +apply Rgt_not_eq, Rlt_gt. +apply Rlt_trans with (2:=Hx), bpow_gt_0. Qed. -Lemma generic_format_pred_1: +(* was succ_le_bpow *) +Theorem id_p_ulp_le_bpow : + forall x e, (0 < x)%R -> F x -> + (x < bpow e)%R -> + (x + ulp x <= bpow e)%R. +Proof. +intros x e Zx Fx Hx. +pattern x at 1 ; rewrite Fx. +rewrite ulp_neq_0. +unfold F2R. simpl. +pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +rewrite <- Rmult_plus_distr_r. +change 1%R with (Z2R 1). +rewrite <- Z2R_plus. +change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R. +apply F2R_p1_le_bpow. +apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +now rewrite <- Fx. +now rewrite <- Fx. +now apply Rgt_not_eq. +Qed. + + + +Lemma generic_format_pred_aux1: forall x, (0 < x)%R -> F x -> x <> bpow (ln_beta beta x - 1) -> F (x - ulp x). @@ -606,7 +505,8 @@ now apply Rlt_le. unfold generic_format, scaled_mantissa, canonic_exp. rewrite ln_beta_unique with beta (x - ulp x)%R ex. pattern x at 1 3 ; rewrite Fx. -unfold ulp, scaled_mantissa. +rewrite ulp_neq_0. +unfold scaled_mantissa. rewrite canonic_exp_fexp with (1 := Ex). unfold F2R. simpl. rewrite Rmult_minus_distr_r. @@ -618,23 +518,27 @@ rewrite Ztrunc_Z2R. rewrite Z2R_minus. rewrite Rmult_minus_distr_r. now rewrite Rmult_1_l. +now apply Rgt_not_eq. rewrite Rabs_pos_eq. split. -apply pred_ge_bpow; trivial. -unfold ulp; intro H. +apply id_m_ulp_ge_bpow; trivial. +rewrite ulp_neq_0. +intro H. assert (ex-1 < canonic_exp beta fexp x < ex)%Z. split ; apply (lt_bpow beta) ; rewrite <- H ; easy. clear -H0. omega. +now apply Rgt_not_eq. apply Ex'. apply Rle_lt_trans with (2 := proj2 Ex'). pattern x at 3 ; rewrite <- Rplus_0_r. apply Rplus_le_compat_l. rewrite <-Ropp_0. apply Ropp_le_contravar. -apply bpow_ge_0. +apply ulp_ge_0. apply Rle_0_minus. pattern x at 2; rewrite Fx. -unfold ulp, F2R; simpl. +rewrite ulp_neq_0. +unfold F2R; simpl. pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l. apply Rmult_le_compat_r. apply bpow_ge_0. @@ -646,9 +550,10 @@ rewrite <- Fx. apply Rle_lt_trans with (2:=proj1 Ex'). apply bpow_ge_0. omega. +now apply Rgt_not_eq. Qed. -Lemma generic_format_pred_2 : +Lemma generic_format_pred_aux2 : forall x, (0 < x)%R -> F x -> let e := ln_beta_val beta x (ln_beta beta x) in x = bpow (e - 1) -> @@ -712,109 +617,210 @@ rewrite Hx, He. ring. Qed. -Theorem generic_format_pred : + +Theorem generic_format_succ_aux1 : forall x, (0 < x)%R -> F x -> - F (pred x). + F (x + ulp x). Proof. intros x Zx Fx. +destruct (ln_beta beta x) as (ex, Ex). +specialize (Ex (Rgt_not_eq _ _ Zx)). +assert (Ex' := Ex). +rewrite Rabs_pos_eq in Ex'. +destruct (id_p_ulp_le_bpow x ex) ; try easy. +unfold generic_format, scaled_mantissa, canonic_exp. +rewrite ln_beta_unique with beta (x + ulp x)%R ex. +pattern x at 1 3 ; rewrite Fx. +rewrite ulp_neq_0. +unfold scaled_mantissa. +rewrite canonic_exp_fexp with (1 := Ex). +unfold F2R. simpl. +rewrite Rmult_plus_distr_r. +rewrite Rmult_assoc. +rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. +change (bpow 0) with (Z2R 1). +rewrite <- Z2R_plus. +rewrite Ztrunc_Z2R. +rewrite Z2R_plus. +rewrite Rmult_plus_distr_r. +now rewrite Rmult_1_l. +now apply Rgt_not_eq. +rewrite Rabs_pos_eq. +split. +apply Rle_trans with (1 := proj1 Ex'). +pattern x at 1 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +apply ulp_ge_0. +exact H. +apply Rplus_le_le_0_compat. +now apply Rlt_le. +apply ulp_ge_0. +rewrite H. +apply generic_format_bpow. +apply valid_exp. +destruct (Zle_or_lt ex (fexp ex)) ; trivial. +elim Rlt_not_le with (1 := Zx). +rewrite Fx. +replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0. +rewrite F2R_0. +apply Rle_refl. +unfold scaled_mantissa. +rewrite canonic_exp_fexp with (1 := Ex). +destruct (mantissa_small_pos beta fexp x ex) ; trivial. +rewrite Ztrunc_floor. +apply sym_eq. +apply Zfloor_imp. +split. +now apply Rlt_le. +exact H2. +now apply Rlt_le. +now apply Rlt_le. +Qed. + +Theorem generic_format_pred_pos : + forall x, F x -> (0 < x)%R -> + F (pred_pos x). +Proof. +intros x Fx Zx. +unfold pred_pos; case Req_bool_spec; intros H. +now apply generic_format_pred_aux2. +now apply generic_format_pred_aux1. +Qed. + + +Theorem generic_format_succ : + forall x, F x -> + F (succ x). +Proof. +intros x Fx. +unfold succ; case Rle_bool_spec; intros Zx. +destruct Zx as [Zx|Zx]. +now apply generic_format_succ_aux1. +rewrite <- Zx, Rplus_0_l. +apply generic_format_ulp_0. +apply generic_format_opp. +apply generic_format_pred_pos. +now apply generic_format_opp. +now apply Ropp_0_gt_lt_contravar. +Qed. + +Theorem generic_format_pred : + forall x, F x -> + F (pred x). +Proof. +intros x Fx. unfold pred. -case Req_bool_spec; intros H. -now apply generic_format_pred_2. -now apply generic_format_pred_1. +apply generic_format_opp. +apply generic_format_succ. +now apply generic_format_opp. Qed. -Theorem generic_format_plus_ulp : - forall { monotone_exp : Monotone_exp fexp }, + + +Theorem pred_pos_lt_id : forall x, (x <> 0)%R -> - F x -> F (x + ulp x). -Proof with auto with typeclass_instances. -intros monotone_exp x Zx Fx. -destruct (Rtotal_order x 0) as [Hx|[Hx|Hx]]. -rewrite <- Ropp_involutive. -apply generic_format_opp. -rewrite Ropp_plus_distr, <- ulp_opp. -apply generic_format_opp in Fx. -destruct (Req_dec (-x) (bpow (ln_beta beta (-x) - 1))) as [Hx'|Hx']. -rewrite Hx' in Fx |- *. -apply generic_format_bpow_inv' in Fx... -unfold ulp, canonic_exp. -rewrite ln_beta_bpow. -revert Fx. -generalize (ln_beta_val _ _ (ln_beta beta (-x)) - 1)%Z. -clear -monotone_exp valid_exp. -intros e He. -destruct (Zle_lt_or_eq _ _ He) as [He1|He1]. -assert (He2 : e = (e - fexp (e + 1) + fexp (e + 1))%Z) by ring. -rewrite He2 at 1. -rewrite bpow_plus. -assert (Hb := Z2R_Zpower beta _ (Zle_minus_le_0 _ _ He)). -match goal with |- F (?a * ?b + - ?b) => - replace (a * b + -b)%R with ((a - 1) * b)%R by ring end. -rewrite <- Hb. -rewrite <- (Z2R_minus _ 1). -change (F (F2R (Float beta (Zpower beta (e - fexp (e + 1)) - 1) (fexp (e + 1))))). -apply generic_format_F2R. -intros Zb. -unfold canonic_exp. -rewrite ln_beta_F2R with (1 := Zb). -rewrite (ln_beta_unique beta _ (e - fexp (e + 1))). -apply monotone_exp. -rewrite <- He2. -apply Zle_succ. -rewrite Rabs_pos_eq. -rewrite Z2R_minus, Hb. -split. -apply Rplus_le_reg_r with (- bpow (e - fexp (e + 1) - 1) + Z2R 1)%R. -apply Rmult_le_reg_r with (bpow (-(e - fexp (e+1) - 1))). + (pred_pos x < x)%R. +Proof. +intros x Zx. +unfold pred_pos. +case Req_bool_spec; intros H. +(* *) +rewrite <- Rplus_0_r. +apply Rplus_lt_compat_l. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. apply bpow_gt_0. -ring_simplify. -apply Rle_trans with R1. -rewrite Rmult_1_l. -apply (bpow_le _ _ 0). -clear -He1 ; omega. -rewrite Ropp_mult_distr_l_reverse. -rewrite <- 2!bpow_plus. -ring_simplify (e - fexp (e + 1) - 1 + - (e - fexp (e + 1) - 1))%Z. -ring_simplify (- (e - fexp (e + 1) - 1) + (e - fexp (e + 1)))%Z. -rewrite bpow_1. -rewrite <- (Z2R_plus (-1) _). -apply (Z2R_le 1). -generalize (Zle_bool_imp_le _ _ (radix_prop beta)). -clear ; omega. -rewrite <- (Rplus_0_r (bpow (e - fexp (e + 1)))) at 2. +(* *) +rewrite <- Rplus_0_r. apply Rplus_lt_compat_l. -now apply (Z2R_lt (-1) 0). -rewrite Z2R_minus. -apply Rle_0_minus. -rewrite Hb. -apply (bpow_le _ 0). -now apply Zle_minus_le_0. -rewrite He1, Rplus_opp_r. -apply generic_format_0. -apply generic_format_pred_1 ; try easy. rewrite <- Ropp_0. -now apply Ropp_lt_contravar. -now elim Zx. -now apply generic_format_succ. +apply Ropp_lt_contravar. +rewrite ulp_neq_0; trivial. +apply bpow_gt_0. Qed. -Theorem generic_format_minus_ulp : - forall { monotone_exp : Monotone_exp fexp }, +Theorem succ_gt_id : forall x, (x <> 0)%R -> - F x -> F (x - ulp x). + (x < succ x)%R. Proof. -intros monotone_exp x Zx Fx. -replace (x - ulp x)%R with (-(-x + ulp x))%R by ring. -apply generic_format_opp. -rewrite <- ulp_opp. -apply generic_format_plus_ulp. -contradict Zx. -rewrite <- (Ropp_involutive x), Zx. -apply Ropp_0. -now apply generic_format_opp. +intros x Zx; unfold succ. +case Rle_bool_spec; intros Hx. +pattern x at 1; rewrite <- (Rplus_0_r x). +apply Rplus_lt_compat_l. +rewrite ulp_neq_0; trivial. +apply bpow_gt_0. +pattern x at 1; rewrite <- (Ropp_involutive x). +apply Ropp_lt_contravar. +apply pred_pos_lt_id. +now auto with real. Qed. -Lemma pred_plus_ulp_1 : + +Theorem pred_lt_id : + forall x, (x <> 0)%R -> + (pred x < x)%R. +Proof. +intros x Zx; unfold pred. +pattern x at 2; rewrite <- (Ropp_involutive x). +apply Ropp_lt_contravar. +apply succ_gt_id. +now auto with real. +Qed. + +Theorem succ_ge_id : + forall x, (x <= succ x)%R. +Proof. +intros x; case (Req_dec x 0). +intros V; rewrite V. +unfold succ; rewrite Rle_bool_true;[idtac|now right]. +rewrite Rplus_0_l; apply ulp_ge_0. +intros; left; now apply succ_gt_id. +Qed. + + +Theorem pred_le_id : + forall x, (pred x <= x)%R. +Proof. +intros x; unfold pred. +pattern x at 2; rewrite <- (Ropp_involutive x). +apply Ropp_le_contravar. +apply succ_ge_id. +Qed. + + +Theorem pred_pos_ge_0 : + forall x, + (0 < x)%R -> F x -> (0 <= pred_pos x)%R. +Proof. +intros x Zx Fx. +unfold pred_pos. +case Req_bool_spec; intros H. +(* *) +apply Rle_0_minus. +rewrite H. +apply bpow_le. +destruct (ln_beta beta x) as (ex,Ex) ; simpl. +rewrite ln_beta_bpow. +ring_simplify (ex - 1 + 1 - 1)%Z. +apply generic_format_bpow_inv with beta; trivial. +simpl in H. +rewrite <- H; assumption. +apply Rle_0_minus. +now apply ulp_le_id. +Qed. + +Theorem pred_ge_0 : + forall x, + (0 < x)%R -> F x -> (0 <= pred x)%R. +Proof. +intros x Zx Fx. +rewrite pred_eq_pos. +now apply pred_pos_ge_0. +now left. +Qed. + + +Lemma pred_pos_plus_ulp_aux1 : forall x, (0 < x)%R -> F x -> x <> bpow (ln_beta beta x - 1) -> ((x - ulp x) + ulp (x-ulp x) = x)%R. @@ -822,24 +828,40 @@ Proof. intros x Zx Fx Hx. replace (ulp (x - ulp x)) with (ulp x). ring. -unfold ulp at 1 2; apply f_equal. +assert (H:(x <> 0)%R) by auto with real. +assert (H':(x <> bpow (canonic_exp beta fexp x))%R). +unfold canonic_exp; intros M. +case_eq (ln_beta beta x); intros ex Hex T. +assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z). +rewrite T; reflexivity. +rewrite Lex in *. +clear T; simpl in *; specialize (Hex H). +rewrite Rabs_right in Hex. +2: apply Rle_ge; apply Rlt_le; easy. +assert (ex-1 < fexp ex < ex)%Z. +split ; apply (lt_bpow beta); rewrite <- M;[idtac|easy]. +destruct (proj1 Hex);[trivial|idtac]. +contradict Hx; auto with real. +omega. +rewrite 2!ulp_neq_0; try auto with real. +apply f_equal. unfold canonic_exp; apply f_equal. -destruct (ln_beta beta x) as (ex, Hex). -simpl in *. -assert (x <> 0)%R by auto with real. +case_eq (ln_beta beta x); intros ex Hex T. +assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z). +rewrite T; reflexivity. +rewrite Lex in *; simpl in *; clear T. specialize (Hex H). -apply sym_eq. -apply ln_beta_unique. +apply sym_eq, ln_beta_unique. rewrite Rabs_right. rewrite Rabs_right in Hex. 2: apply Rle_ge; apply Rlt_le; easy. split. destruct Hex as ([H1|H1],H2). -apply pred_ge_bpow; trivial. -unfold ulp; intros H3. -assert (ex-1 < canonic_exp beta fexp x < ex)%Z. -split ; apply (lt_bpow beta) ; rewrite <- H3 ; easy. -omega. +apply Rle_trans with (x-ulp x)%R. +apply id_m_ulp_ge_bpow; trivial. +rewrite ulp_neq_0; trivial. +rewrite ulp_neq_0; trivial. +right; unfold canonic_exp; now rewrite Lex. contradict Hx; auto with real. apply Rle_lt_trans with (2:=proj2 Hex). rewrite <- Rplus_0_r. @@ -849,9 +871,10 @@ apply Ropp_le_contravar. apply bpow_ge_0. apply Rle_ge. apply Rle_0_minus. -pattern x at 2; rewrite Fx. -unfold ulp, F2R; simpl. -pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l. +rewrite Fx. +unfold F2R, canonic_exp; simpl. +rewrite Lex. +pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l. apply Rmult_le_compat_r. apply bpow_ge_0. replace 1%R with (Z2R (Zsucc 0)) by reflexivity. @@ -861,7 +884,8 @@ apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). now rewrite <- Fx. Qed. -Lemma pred_plus_ulp_2 : + +Lemma pred_pos_plus_ulp_aux2 : forall x, (0 < x)%R -> F x -> let e := ln_beta_val beta x (ln_beta beta x) in x = bpow (e - 1) -> @@ -876,7 +900,8 @@ apply generic_format_bpow_inv with beta; trivial. rewrite <- Hxe; assumption. case (Zle_lt_or_eq _ _ He); clear He; intros He. (* *) -unfold ulp; apply f_equal. +rewrite ulp_neq_0; trivial. +apply f_equal. unfold canonic_exp; apply f_equal. apply sym_eq. apply ln_beta_unique. @@ -915,90 +940,271 @@ contradict Zp. rewrite Hxe, He; ring. Qed. -Theorem pred_plus_ulp : +Lemma pred_pos_plus_ulp_aux3 : forall x, (0 < x)%R -> F x -> - (pred x <> 0)%R -> - (pred x + ulp (pred x) = x)%R. + let e := ln_beta_val beta x (ln_beta beta x) in + x = bpow (e - 1) -> + (x - bpow (fexp (e-1)) = 0)%R -> + (ulp 0 = x)%R. Proof. -intros x Zx Fx. -unfold pred. -case Req_bool_spec; intros H Zp. -now apply pred_plus_ulp_2. -now apply pred_plus_ulp_1. +intros x Hx Fx e H1 H2. +assert (H3:(x = bpow (fexp (e - 1)))). +now apply Rminus_diag_uniq. +assert (H4: (fexp (e-1) = e-1)%Z). +apply bpow_inj with beta. +now rewrite <- H1. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros K. +specialize (K (e-1)%Z). +contradict K; omega. +intros n Hn. +rewrite H3; apply f_equal. +case (Zle_or_lt n (e-1)); intros H6. +apply valid_exp; omega. +apply sym_eq, valid_exp; omega. Qed. -Theorem pred_lt_id : - forall x, - (pred x < x)%R. + + + +(** The following one is false for x = 0 in FTZ *) + +Theorem pred_pos_plus_ulp : + forall x, (0 < x)%R -> F x -> + (pred_pos x + ulp (pred_pos x) = x)%R. Proof. -intros. -unfold pred. +intros x Zx Fx. +unfold pred_pos. case Req_bool_spec; intros H. -(* *) -rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. +case (Req_EM_T (x - bpow (fexp (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1. +rewrite H1, Rplus_0_l. +now apply pred_pos_plus_ulp_aux3. +now apply pred_pos_plus_ulp_aux2. +now apply pred_pos_plus_ulp_aux1. +Qed. + + + + +(** Rounding x + small epsilon *) + +Theorem ln_beta_plus_eps: + forall x, (0 < x)%R -> F x -> + forall eps, (0 <= eps < ulp x)%R -> + ln_beta beta (x + eps) = ln_beta beta x :> Z. +Proof. +intros x Zx Fx eps Heps. +destruct (ln_beta beta x) as (ex, He). +simpl. +specialize (He (Rgt_not_eq _ _ Zx)). +apply ln_beta_unique. +rewrite Rabs_pos_eq. +rewrite Rabs_pos_eq in He. +split. +apply Rle_trans with (1 := proj1 He). +pattern x at 1 ; rewrite <- Rplus_0_r. +now apply Rplus_le_compat_l. +apply Rlt_le_trans with (x + ulp x)%R. +now apply Rplus_lt_compat_l. +pattern x at 1 ; rewrite Fx. +rewrite ulp_neq_0. +unfold F2R. simpl. +pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +rewrite <- Rmult_plus_distr_r. +change 1%R with (Z2R 1). +rewrite <- Z2R_plus. +change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R. +apply F2R_p1_le_bpow. +apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +now rewrite <- Fx. +now rewrite <- Fx. +now apply Rgt_not_eq. +now apply Rlt_le. +apply Rplus_le_le_0_compat. +now apply Rlt_le. +apply Heps. +Qed. + +Theorem round_DN_plus_eps_pos: + forall x, (0 <= x)%R -> F x -> + forall eps, (0 <= eps < ulp x)%R -> + round beta fexp Zfloor (x + eps) = x. +Proof. +intros x Zx Fx eps Heps. +destruct Zx as [Zx|Zx]. +(* . 0 < x *) +pattern x at 2 ; rewrite Fx. +unfold round. +unfold scaled_mantissa. simpl. +unfold canonic_exp at 1 2. +rewrite ln_beta_plus_eps ; trivial. +apply (f_equal (fun m => F2R (Float beta m _))). +rewrite Ztrunc_floor. +apply Zfloor_imp. +split. +apply (Rle_trans _ _ _ (Zfloor_lb _)). +apply Rmult_le_compat_r. +apply bpow_ge_0. +pattern x at 1 ; rewrite <- Rplus_0_r. +now apply Rplus_le_compat_l. +apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R. +apply Rmult_lt_compat_r. apply bpow_gt_0. -(* *) -rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. +now apply Rplus_lt_compat_l. +rewrite Rmult_plus_distr_r. +rewrite Z2R_plus. +apply Rplus_le_compat. +pattern x at 1 3 ; rewrite Fx. +unfold F2R. simpl. +rewrite Rmult_assoc. +rewrite <- bpow_plus. +rewrite Zplus_opp_r. +rewrite Rmult_1_r. +rewrite Zfloor_Z2R. +apply Rle_refl. +rewrite ulp_neq_0. +2: now apply Rgt_not_eq. +rewrite <- bpow_plus. +rewrite Zplus_opp_r. +apply Rle_refl. +apply Rmult_le_pos. +now apply Rlt_le. +apply bpow_ge_0. +(* . x=0 *) +rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps. +case (proj1 Heps); intros P. +unfold round, scaled_mantissa, canonic_exp. +revert Heps; unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros _ (H1,H2). +absurd (0 < 0)%R; auto with real. +now apply Rle_lt_trans with (1:=H1). +intros n Hn H. +assert (fexp (ln_beta beta eps) = fexp n). +apply valid_exp; try assumption. +assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (2:=proj2 H). +destruct (ln_beta beta eps) as (e,He). +simpl; rewrite Rabs_pos_eq in He. +now apply He, Rgt_not_eq. +now left. +replace (Zfloor (eps * bpow (- fexp (ln_beta beta eps)))) with 0%Z. +unfold F2R; simpl; ring. +apply sym_eq, Zfloor_imp. +split. +apply Rmult_le_pos. +now left. +apply bpow_ge_0. +apply Rmult_lt_reg_r with (bpow (fexp n)). apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus. +rewrite H0; ring_simplify (-fexp n + fexp n)%Z. +simpl; rewrite Rmult_1_l, Rmult_1_r. +apply H. +rewrite <- P, round_0; trivial. +apply valid_rnd_DN. Qed. -Theorem pred_ge_0 : - forall x, - (0 < x)%R -> F x -> (0 <= pred x)%R. -intros x Zx Fx. -unfold pred. -case Req_bool_spec; intros H. -(* *) -apply Rle_0_minus. -rewrite H. -apply bpow_le. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -rewrite ln_beta_bpow. -ring_simplify (ex - 1 + 1 - 1)%Z. -apply generic_format_bpow_inv with beta; trivial. -simpl in H. -rewrite <- H; assumption. -apply Rle_0_minus. -now apply ulp_le_id. + +Theorem round_UP_plus_eps_pos : + forall x, (0 <= x)%R -> F x -> + forall eps, (0 < eps <= ulp x)%R -> + round beta fexp Zceil (x + eps) = (x + ulp x)%R. +Proof with auto with typeclass_instances. +intros x Zx Fx eps. +case Zx; intros Zx1. +(* . 0 < x *) +intros (Heps1,[Heps2|Heps2]). +assert (Heps: (0 <= eps < ulp x)%R). +split. +now apply Rlt_le. +exact Heps2. +assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps). +rewrite round_UP_DN_ulp. +rewrite Hd. +rewrite 2!ulp_neq_0. +unfold canonic_exp. +now rewrite ln_beta_plus_eps. +now apply Rgt_not_eq. +now apply Rgt_not_eq, Rplus_lt_0_compat. +intros Fs. +rewrite round_generic in Hd... +apply Rgt_not_eq with (2 := Hd). +pattern x at 2 ; rewrite <- Rplus_0_r. +now apply Rplus_lt_compat_l. +rewrite Heps2. +apply round_generic... +now apply generic_format_succ_aux1. +(* . x=0 *) +rewrite <- Zx1, 2!Rplus_0_l. +intros Heps. +case (proj2 Heps). +unfold round, scaled_mantissa, canonic_exp. +unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros H2. +intros J; absurd (0 < 0)%R; auto with real. +apply Rlt_trans with eps; try assumption; apply Heps. +intros n Hn H. +assert (fexp (ln_beta beta eps) = fexp n). +apply valid_exp; try assumption. +assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (2:=H). +destruct (ln_beta beta eps) as (e,He). +simpl; rewrite Rabs_pos_eq in He. +now apply He, Rgt_not_eq. +now left. +replace (Zceil (eps * bpow (- fexp (ln_beta beta eps)))) with 1%Z. +unfold F2R; simpl; rewrite H0; ring. +apply sym_eq, Zceil_imp. +split. +simpl; apply Rmult_lt_0_compat. +apply Heps. +apply bpow_gt_0. +apply Rmult_le_reg_r with (bpow (fexp n)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus. +rewrite H0; ring_simplify (-fexp n + fexp n)%Z. +simpl; rewrite Rmult_1_l, Rmult_1_r. +now left. +intros P; rewrite P. +apply round_generic... +apply generic_format_ulp_0. Qed. -Theorem round_UP_pred : - forall x, (0 < pred x)%R -> F x -> + +Theorem round_UP_pred_plus_eps_pos : + forall x, (0 < x)%R -> F x -> forall eps, (0 < eps <= ulp (pred x) )%R -> round beta fexp Zceil (pred x + eps) = x. Proof. intros x Hx Fx eps Heps. -rewrite round_UP_succ; trivial. -apply pred_plus_ulp; trivial. -apply Rlt_trans with (1:=Hx). -apply pred_lt_id. -now apply Rgt_not_eq. +rewrite round_UP_plus_eps_pos; trivial. +rewrite pred_eq_pos. +apply pred_pos_plus_ulp; trivial. +now left. +now apply pred_ge_0. apply generic_format_pred; trivial. -apply Rlt_trans with (1:=Hx). -apply pred_lt_id. Qed. -Theorem round_DN_pred : - forall x, (0 < pred x)%R -> F x -> +Theorem round_DN_minus_eps_pos : + forall x, (0 < x)%R -> F x -> forall eps, (0 < eps <= ulp (pred x))%R -> round beta fexp Zfloor (x - eps) = pred x. Proof. -intros x Hpx Fx eps Heps. -assert (Hx:(0 < x)%R). -apply Rlt_trans with (1:=Hpx). -apply pred_lt_id. -replace (x-eps)%R with (pred x + (ulp (pred x)-eps))%R. -2: pattern x at 3; rewrite <- (pred_plus_ulp x); trivial. +intros x Hpx Fx eps. +rewrite pred_eq_pos;[intros Heps|now left]. +replace (x-eps)%R with (pred_pos x + (ulp (pred_pos x)-eps))%R. +2: pattern x at 3; rewrite <- (pred_pos_plus_ulp x); trivial. 2: ring. -2: now apply Rgt_not_eq. -rewrite round_DN_succ; trivial. -now apply generic_format_pred. +rewrite round_DN_plus_eps_pos; trivial. +now apply pred_pos_ge_0. +now apply generic_format_pred_pos. split. apply Rle_0_minus. now apply Heps. @@ -1009,15 +1215,96 @@ apply Ropp_lt_contravar. now apply Heps. Qed. -Lemma le_pred_lt_aux : + +Theorem round_DN_plus_eps: + forall x, F x -> + forall eps, (0 <= eps < if (Rle_bool 0 x) then (ulp x) + else (ulp (pred (-x))))%R -> + round beta fexp Zfloor (x + eps) = x. +Proof. +intros x Fx eps Heps. +case (Rle_or_lt 0 x); intros Zx. +apply round_DN_plus_eps_pos; try assumption. +split; try apply Heps. +rewrite Rle_bool_true in Heps; trivial. +now apply Heps. +(* *) +rewrite Rle_bool_false in Heps; trivial. +rewrite <- (Ropp_involutive (x+eps)). +pattern x at 2; rewrite <- (Ropp_involutive x). +rewrite round_DN_opp. +apply f_equal. +replace (-(x+eps))%R with (pred (-x) + (ulp (pred (-x)) - eps))%R. +rewrite round_UP_pred_plus_eps_pos; try reflexivity. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +split. +apply Rplus_lt_reg_l with eps; ring_simplify. +apply Heps. +apply Rplus_le_reg_l with (eps-ulp (pred (- x)))%R; ring_simplify. +apply Heps. +unfold pred. +rewrite Ropp_involutive. +unfold succ; rewrite Rle_bool_false; try assumption. +rewrite Ropp_involutive; unfold Rminus. +rewrite <- Rplus_assoc, pred_pos_plus_ulp. +ring. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +Qed. + + +Theorem round_UP_plus_eps : + forall x, F x -> + forall eps, (0 < eps <= if (Rle_bool 0 x) then (ulp x) + else (ulp (pred (-x))))%R -> + round beta fexp Zceil (x + eps) = (succ x)%R. +Proof with auto with typeclass_instances. +intros x Fx eps Heps. +case (Rle_or_lt 0 x); intros Zx. +rewrite succ_eq_pos; try assumption. +rewrite Rle_bool_true in Heps; trivial. +apply round_UP_plus_eps_pos; assumption. +(* *) +rewrite Rle_bool_false in Heps; trivial. +rewrite <- (Ropp_involutive (x+eps)). +rewrite <- (Ropp_involutive (succ x)). +rewrite round_UP_opp. +apply f_equal. +replace (-(x+eps))%R with (-succ x + (-eps + ulp (pred (-x))))%R. +apply round_DN_plus_eps_pos. +rewrite <- pred_opp. +apply pred_ge_0. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +now apply generic_format_opp, generic_format_succ. +split. +apply Rplus_le_reg_l with eps; ring_simplify. +apply Heps. +unfold pred; rewrite Ropp_involutive. +apply Rplus_lt_reg_l with (eps-ulp (- succ x))%R; ring_simplify. +apply Heps. +unfold succ; rewrite Rle_bool_false; try assumption. +apply trans_eq with (-x +-eps)%R;[idtac|ring]. +pattern (-x)%R at 3; rewrite <- (pred_pos_plus_ulp (-x)). +rewrite pred_eq_pos. +ring. +left; now apply Ropp_0_gt_lt_contravar. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +Qed. + + +Lemma le_pred_pos_lt : forall x y, F x -> F y -> - (0 < x < y)%R -> - (x <= pred y)%R. + (0 <= x < y)%R -> + (x <= pred_pos y)%R. Proof with auto with typeclass_instances. -intros x y Hx Hy H. +intros x y Fx Fy H. +case (proj1 H); intros V. assert (Zy:(0 < y)%R). -apply Rlt_trans with (1:=proj1 H). +apply Rle_lt_trans with (1:=proj1 H). apply H. (* *) assert (Zp: (0 < pred y)%R). @@ -1025,7 +1312,8 @@ assert (Zp:(0 <= pred y)%R). apply pred_ge_0 ; trivial. destruct Zp; trivial. generalize H0. -unfold pred. +rewrite pred_eq_pos;[idtac|now left]. +unfold pred_pos. destruct (ln_beta beta y) as (ey,Hey); simpl. case Req_bool_spec; intros Hy2. (* . *) @@ -1058,7 +1346,7 @@ absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z. omega. split. apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Hx. +now rewrite <- Fx. apply lt_Z2R. apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)). apply bpow_gt_0. @@ -1082,7 +1370,8 @@ intros Hy3. assert (y = bpow (fexp ey))%R. apply Rminus_diag_uniq. rewrite Hy3. -unfold ulp, canonic_exp. +rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. +unfold canonic_exp. rewrite (ln_beta_unique beta y ey); trivial. apply Hey. now apply Rgt_not_eq. @@ -1104,68 +1393,701 @@ apply ln_beta_unique. apply Hey. now apply Rgt_not_eq. (* *) -case (Rle_or_lt (ulp (pred y)) (y-x)); intros H1. +case (Rle_or_lt (ulp (pred_pos y)) (y-x)); intros H1. (* . *) -apply Rplus_le_reg_r with (-x + ulp (pred y))%R. -ring_simplify (x+(-x+ulp (pred y)))%R. +apply Rplus_le_reg_r with (-x + ulp (pred_pos y))%R. +ring_simplify (x+(-x+ulp (pred_pos y)))%R. apply Rle_trans with (1:=H1). -rewrite <- (pred_plus_ulp y) at 1; trivial. +rewrite <- (pred_pos_plus_ulp y) at 1; trivial. apply Req_le; ring. -now apply Rgt_not_eq. (* . *) replace x with (y-(y-x))%R by ring. -rewrite <- round_DN_pred with (eps:=(y-x)%R); try easy. +rewrite <- pred_eq_pos;[idtac|now left]. +rewrite <- round_DN_minus_eps_pos with (eps:=(y-x)%R); try easy. ring_simplify (y-(y-x))%R. apply Req_le. apply sym_eq. apply round_generic... split; trivial. now apply Rlt_Rminus. +rewrite pred_eq_pos;[idtac|now left]. now apply Rlt_le. +rewrite <- V; apply pred_pos_ge_0; trivial. +apply Rle_lt_trans with (1:=proj1 H); apply H. +Qed. + +Theorem succ_le_lt_aux: + forall x y, + F x -> F y -> + (0 <= x)%R -> (x < y)%R -> + (succ x <= y)%R. +Proof with auto with typeclass_instances. +intros x y Hx Hy Zx H. +rewrite succ_eq_pos; trivial. +case (Rle_or_lt (ulp x) (y-x)); intros H1. +apply Rplus_le_reg_r with (-x)%R. +now ring_simplify (x+ulp x + -x)%R. +replace y with (x+(y-x))%R by ring. +absurd (x < y)%R. +2: apply H. +apply Rle_not_lt; apply Req_le. +rewrite <- round_DN_plus_eps_pos with (eps:=(y-x)%R); try easy. +ring_simplify (x+(y-x))%R. +apply sym_eq. +apply round_generic... +split; trivial. +apply Rlt_le; now apply Rlt_Rminus. +Qed. + +Theorem succ_le_lt: + forall x y, + F x -> F y -> + (x < y)%R -> + (succ x <= y)%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +now apply succ_le_lt_aux. +unfold succ; rewrite Rle_bool_false; try assumption. +case (Rle_or_lt y 0); intros Hy. +rewrite <- (Ropp_involutive y). +apply Ropp_le_contravar. +apply le_pred_pos_lt. +now apply generic_format_opp. +now apply generic_format_opp. +split. +rewrite <- Ropp_0; now apply Ropp_le_contravar. +now apply Ropp_lt_contravar. +apply Rle_trans with (-0)%R. +apply Ropp_le_contravar. +apply pred_pos_ge_0. +rewrite <- Ropp_0; now apply Ropp_lt_contravar. +now apply generic_format_opp. +rewrite Ropp_0; now left. Qed. Theorem le_pred_lt : forall x y, F x -> F y -> - (0 < y)%R -> (x < y)%R -> (x <= pred y)%R. Proof. -intros x y Fx Fy Hy Hxy. -destruct (Rle_or_lt x 0) as [Hx|Hx]. -apply Rle_trans with (1 := Hx). -now apply pred_ge_0. -apply le_pred_lt_aux ; try easy. -now split. +intros x y Fx Fy Hxy. +rewrite <- (Ropp_involutive x). +unfold pred; apply Ropp_le_contravar. +apply succ_le_lt. +now apply generic_format_opp. +now apply generic_format_opp. +now apply Ropp_lt_contravar. Qed. -Theorem pred_succ : forall { monotone_exp : Monotone_exp fexp }, - forall x, F x -> (0 < x)%R -> pred (x + ulp x)=x. +Theorem lt_succ_le: + forall x y, + F x -> F y -> (y <> 0)%R -> + (x <= y)%R -> + (x < succ y)%R. Proof. -intros L x Fx Hx. -assert (x <= pred (x + ulp x))%R. -apply le_pred_lt. -assumption. -now apply generic_format_succ. -replace 0%R with (0+0)%R by ring; apply Rplus_lt_compat; try apply Hx. +intros x y Fx Fy Zy Hxy. +case (Rle_or_lt (succ y) x); trivial; intros H. +absurd (succ y = y)%R. +apply Rgt_not_eq. +now apply succ_gt_id. +apply Rle_antisym. +now apply Rle_trans with x. +apply succ_ge_id. +Qed. + + +Theorem succ_pred_aux : forall x, F x -> (0 < x)%R -> succ (pred x)=x. +Proof. +intros x Fx Hx. +rewrite pred_eq_pos;[idtac|now left]. +rewrite succ_eq_pos. +2: now apply pred_pos_ge_0. +now apply pred_pos_plus_ulp. +Qed. + +Theorem pred_succ_aux_0 : (pred (succ 0)=0)%R. +Proof. +unfold succ; rewrite Rle_bool_true. +2: apply Rle_refl. +rewrite Rplus_0_l. +rewrite pred_eq_pos. +2: apply ulp_ge_0. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +(* *) +intros (H1,H2); rewrite H1. +unfold pred_pos; rewrite Req_bool_false. +2: apply Rlt_not_eq, bpow_gt_0. +unfold ulp; rewrite Req_bool_true; trivial. +rewrite H1; ring. +(* *) +intros (n,(H1,H2)); rewrite H1. +unfold pred_pos. +rewrite ln_beta_bpow. +replace (fexp n + 1 - 1)%Z with (fexp n) by ring. +rewrite Req_bool_true; trivial. +apply Rminus_diag_eq, f_equal. +apply sym_eq, valid_exp; omega. +Qed. + +Theorem pred_succ_aux : forall x, F x -> (0 < x)%R -> pred (succ x)=x. +Proof. +intros x Fx Hx. +rewrite succ_eq_pos;[idtac|now left]. +rewrite pred_eq_pos. +2: apply Rplus_le_le_0_compat;[now left| apply ulp_ge_0]. +unfold pred_pos. +case Req_bool_spec; intros H1. +(* *) +pose (l:=(ln_beta beta (x+ulp x))). +rewrite H1 at 1; fold l. +apply Rplus_eq_reg_r with (ulp x). +rewrite H1; fold l. +rewrite (ulp_neq_0 x) at 3. +2: now apply Rgt_not_eq. +unfold canonic_exp. +replace (fexp (ln_beta beta x)) with (fexp (l-1))%Z. +ring. +apply f_equal, sym_eq. +apply Zle_antisym. +assert (ln_beta beta x - 1 < l - 1)%Z;[idtac|omega]. +apply lt_bpow with beta. +unfold l; rewrite <- H1. +apply Rle_lt_trans with x. +destruct (ln_beta beta x) as (e,He); simpl. +rewrite <- (Rabs_right x) at 1. +2: apply Rle_ge; now left. +now apply He, Rgt_not_eq. +apply Rplus_lt_reg_l with (-x)%R; ring_simplify. +rewrite ulp_neq_0. apply bpow_gt_0. -apply Rplus_lt_reg_r with (-x)%R; ring_simplify. +now apply Rgt_not_eq. +apply le_bpow with beta. +unfold l; rewrite <- H1. +apply id_p_ulp_le_bpow; trivial. +rewrite <- (Rabs_right x) at 1. +2: apply Rle_ge; now left. +apply bpow_ln_beta_gt. +(* *) +replace (ulp (x+ ulp x)) with (ulp x). +ring. +rewrite ulp_neq_0 at 1. +2: now apply Rgt_not_eq. +rewrite ulp_neq_0 at 1. +2: apply Rgt_not_eq, Rlt_gt. +2: apply Rlt_le_trans with (1:=Hx). +2: apply Rplus_le_reg_l with (-x)%R; ring_simplify. +2: apply ulp_ge_0. +apply f_equal; unfold canonic_exp; apply f_equal. +apply sym_eq, ln_beta_unique. +rewrite Rabs_right. +2: apply Rle_ge; left. +2: apply Rlt_le_trans with (1:=Hx). +2: apply Rplus_le_reg_l with (-x)%R; ring_simplify. +2: apply ulp_ge_0. +destruct (ln_beta beta x) as (e,He); simpl. +rewrite Rabs_right in He. +2: apply Rle_ge; now left. +split. +apply Rle_trans with x. +apply He, Rgt_not_eq; assumption. +apply Rplus_le_reg_l with (-x)%R; ring_simplify. +apply ulp_ge_0. +case (Rle_lt_or_eq_dec (x+ulp x) (bpow e)); trivial. +apply id_p_ulp_le_bpow; trivial. +apply He, Rgt_not_eq; assumption. +intros K; contradict H1. +rewrite K, ln_beta_bpow. +apply f_equal; ring. +Qed. + + + +Theorem succ_pred : forall x, F x -> succ (pred x)=x. +Proof. +intros x Fx. +case (Rle_or_lt 0 x); intros Hx. +destruct Hx as [Hx|Hx]. +now apply succ_pred_aux. +rewrite <- Hx. +rewrite pred_eq_opp_succ_opp, succ_opp, Ropp_0. +rewrite pred_succ_aux_0; ring. +rewrite pred_eq_opp_succ_opp, succ_opp. +rewrite pred_succ_aux. +ring. +now apply generic_format_opp. +now apply Ropp_0_gt_lt_contravar. +Qed. + +Theorem pred_succ : forall x, F x -> pred (succ x)=x. +Proof. +intros x Fx. +case (Rle_or_lt 0 x); intros Hx. +destruct Hx as [Hx|Hx]. +now apply pred_succ_aux. +rewrite <- Hx. +apply pred_succ_aux_0. +rewrite succ_eq_opp_pred_opp, pred_opp. +rewrite succ_pred_aux. +ring. +now apply generic_format_opp. +now apply Ropp_0_gt_lt_contravar. +Qed. + + +Theorem round_UP_pred_plus_eps : + forall x, F x -> + forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) + else (ulp (pred x)))%R -> + round beta fexp Zceil (pred x + eps) = x. +Proof. +intros x Fx eps Heps. +rewrite round_UP_plus_eps. +now apply succ_pred. +now apply generic_format_pred. +unfold pred at 4. +rewrite Ropp_involutive, pred_succ. +rewrite ulp_opp. +generalize Heps; case (Rle_bool_spec x 0); intros H1 H2. +rewrite Rle_bool_false; trivial. +case H1; intros H1'. +apply Rlt_le_trans with (2:=H1). +apply pred_lt_id. +now apply Rlt_not_eq. +rewrite H1'; unfold pred, succ. +rewrite Ropp_0; rewrite Rle_bool_true;[idtac|now right]. +rewrite Rplus_0_l. +rewrite <- Ropp_0; apply Ropp_lt_contravar. +apply Rlt_le_trans with (1:=proj1 H2). +apply Rle_trans with (1:=proj2 H2). +rewrite Ropp_0, H1'. +now right. +rewrite Rle_bool_true; trivial. +now apply pred_ge_0. +now apply generic_format_opp. +Qed. + + +Theorem round_DN_minus_eps: + forall x, F x -> + forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) + else (ulp (pred x)))%R -> + round beta fexp Zfloor (x - eps) = pred x. +Proof. +intros x Fx eps Heps. +replace (x-eps)%R with (-(-x+eps))%R by ring. +rewrite round_DN_opp. +unfold pred; apply f_equal. +pattern (-x)%R at 1; rewrite <- (pred_succ (-x)). +apply round_UP_pred_plus_eps. +now apply generic_format_succ, generic_format_opp. +rewrite pred_succ. +rewrite ulp_opp. +generalize Heps; case (Rle_bool_spec x 0); intros H1 H2. +rewrite Rle_bool_false; trivial. +case H1; intros H1'. +apply Rlt_le_trans with (-x)%R. +now apply Ropp_0_gt_lt_contravar. +apply succ_ge_id. +rewrite H1', Ropp_0, succ_eq_pos;[idtac|now right]. +rewrite Rplus_0_l. +apply Rlt_le_trans with (1:=proj1 H2). +rewrite H1' in H2; apply H2. +rewrite Rle_bool_true. +now rewrite succ_opp, ulp_opp. +rewrite succ_opp. +rewrite <- Ropp_0; apply Ropp_le_contravar. +now apply pred_ge_0. +now apply generic_format_opp. +now apply generic_format_opp. +Qed. + +(** Error of a rounding, expressed in number of ulps *) +(** false for x=0 in the FLX format *) +(* was ulp_error *) +Theorem error_lt_ulp : + forall rnd { Zrnd : Valid_rnd rnd } x, + (x <> 0)%R -> + (Rabs (round beta fexp rnd x - x) < ulp x)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x Zx. +destruct (generic_format_EM beta fexp x) as [Hx|Hx]. +(* x = rnd x *) +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +rewrite ulp_neq_0; trivial. apply bpow_gt_0. -apply Rle_antisym; trivial. -apply Rplus_le_reg_r with (ulp (pred (x + ulp x))). -rewrite pred_plus_ulp. -apply Rplus_le_compat_l. -now apply ulp_le. -replace 0%R with (0+0)%R by ring; apply Rplus_lt_compat; try apply Hx. +(* x <> rnd x *) +destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H. +(* . *) +rewrite Rabs_left1. +rewrite Ropp_minus_distr. +apply Rplus_lt_reg_l with (round beta fexp Zfloor x). +rewrite <- round_UP_DN_ulp with (1 := Hx). +ring_simplify. +assert (Hu: (x <= round beta fexp Zceil x)%R). +apply round_UP_pt... +destruct Hu as [Hu|Hu]. +exact Hu. +elim Hx. +rewrite Hu. +apply generic_format_round... +apply Rle_minus. +apply round_DN_pt... +(* . *) +rewrite Rabs_pos_eq. +rewrite round_UP_DN_ulp with (1 := Hx). +apply Rplus_lt_reg_r with (x - ulp x)%R. +ring_simplify. +assert (Hd: (round beta fexp Zfloor x <= x)%R). +apply round_DN_pt... +destruct Hd as [Hd|Hd]. +exact Hd. +elim Hx. +rewrite <- Hd. +apply generic_format_round... +apply Rle_0_minus. +apply round_UP_pt... +Qed. + +(* was ulp_error_le *) +Theorem error_le_ulp : + forall rnd { Zrnd : Valid_rnd rnd } x, + (Rabs (round beta fexp rnd x - x) <= ulp x)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x. +case (Req_dec x 0). +intros Zx; rewrite Zx, round_0... +unfold Rminus; rewrite Rplus_0_l, Ropp_0, Rabs_R0. +apply ulp_ge_0. +intros Zx; left. +now apply error_lt_ulp. +Qed. + +(* was ulp_half_error *) +Theorem error_le_half_ulp : + forall choice x, + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R. +Proof with auto with typeclass_instances. +intros choice x. +destruct (generic_format_EM beta fexp x) as [Hx|Hx]. +(* x = rnd x *) +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +apply Rmult_le_pos. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply (Z2R_lt 0 2). +apply ulp_ge_0. +(* x <> rnd x *) +set (d := round beta fexp Zfloor x). +destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2). +destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H]. +(* . rnd(x) = rndd(x) *) +apply Rle_trans with (Rabs (d - x)). +apply Hr2. +apply (round_DN_pt beta fexp x). +rewrite Rabs_left1. +rewrite Ropp_minus_distr. +apply Rmult_le_reg_r with 2%R. +now apply (Z2R_lt 0 2). +apply Rplus_le_reg_r with (d - x)%R. +ring_simplify. +apply Rle_trans with (1 := H). +right. field. +apply Rle_minus. +apply (round_DN_pt beta fexp x). +(* . rnd(x) = rndu(x) *) +assert (Hu: (d + ulp x)%R = round beta fexp Zceil x). +unfold d. +now rewrite <- round_UP_DN_ulp. +apply Rle_trans with (Rabs (d + ulp x - x)). +apply Hr2. +rewrite Hu. +apply (round_UP_pt beta fexp x). +rewrite Rabs_pos_eq. +apply Rmult_le_reg_r with 2%R. +now apply (Z2R_lt 0 2). +apply Rplus_le_reg_r with (- (d + ulp x - x))%R. +ring_simplify. +apply Rlt_le. +apply Rlt_le_trans with (1 := H). +right. field. +apply Rle_0_minus. +rewrite Hu. +apply (round_UP_pt beta fexp x). +Qed. + + +Theorem ulp_DN : + forall x, + (0 < round beta fexp Zfloor x)%R -> + ulp (round beta fexp Zfloor x) = ulp x. +Proof with auto with typeclass_instances. +intros x Hd. +rewrite 2!ulp_neq_0. +now rewrite canonic_exp_DN with (2 := Hd). +intros T; contradict Hd; rewrite T, round_0... +apply Rlt_irrefl. +now apply Rgt_not_eq. +Qed. + +Theorem round_neq_0_negligible_exp: + negligible_exp=None -> forall rnd { Zrnd : Valid_rnd rnd } x, + (x <> 0)%R -> (round beta fexp rnd x <> 0)%R. +Proof with auto with typeclass_instances. +intros H rndn Hrnd x Hx K. +case negligible_exp_spec'. +intros (_,Hn). +destruct (ln_beta beta x) as (e,He). +absurd (fexp e < e)%Z. +apply Zle_not_lt. +apply exp_small_round_0 with beta rndn x... +apply (Hn e). +intros (n,(H1,_)). +rewrite H in H1; discriminate. +Qed. + + +(** allows rnd x to be 0 *) +(* was ulp_error_f *) +Theorem error_lt_ulp_round : + forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, + ( x <> 0)%R -> + (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R. +Proof with auto with typeclass_instances. +intros Hm. +(* wlog *) +cut (forall rnd : R -> Z, Valid_rnd rnd -> forall x : R, (0 < x)%R -> + (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R). +intros M rnd Hrnd x Zx. +case (Rle_or_lt 0 x). +intros H; destruct H. +now apply M. +contradict H; now apply sym_not_eq. +intros H. +rewrite <- (Ropp_involutive x). +rewrite round_opp, ulp_opp. +replace (- round beta fexp (Zrnd_opp rnd) (- x) - - - x)%R with + (-(round beta fexp (Zrnd_opp rnd) (- x) - (-x)))%R by ring. +rewrite Rabs_Ropp. +apply M. +now apply valid_rnd_opp. +now apply Ropp_0_gt_lt_contravar. +(* 0 < x *) +intros rnd Hrnd x Hx. +case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). +apply round_ge_generic... +apply generic_format_0. +now left. +(* . 0 < round Zfloor x *) +intros Hx2. +apply Rlt_le_trans with (ulp x). +apply error_lt_ulp... +now apply Rgt_not_eq. +rewrite <- ulp_DN; trivial. +apply ulp_le_pos. +now left. +case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V. +apply Rle_refl. +apply Rle_trans with x. +apply round_DN_pt... +apply round_UP_pt... +(* . 0 = round Zfloor x *) +intros Hx2. +case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V; clear V. +(* .. round down -- difficult case *) +rewrite <- Hx2. +unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec. +(* without minimal exponent *) +intros K; contradict Hx2. +apply Rlt_not_eq. +apply F2R_gt_0_compat; simpl. +apply Zlt_le_trans with 1%Z. +apply Pos2Z.is_pos. +apply Zfloor_lub. +simpl; unfold scaled_mantissa, canonic_exp. +destruct (ln_beta beta x) as (e,He); simpl. +apply Rle_trans with (bpow (e-1) * bpow (- fexp e))%R. +rewrite <- bpow_plus. +replace 1%R with (bpow 0) by reflexivity. +apply bpow_le. +specialize (K e); omega. +apply Rmult_le_compat_r. +apply bpow_ge_0. +rewrite <- (Rabs_pos_eq x). +now apply He, Rgt_not_eq. +now left. +(* with a minimal exponent *) +intros n Hn. +rewrite Rabs_pos_eq;[idtac|now left]. +case (Rle_or_lt (bpow (fexp n)) x); trivial. +intros K; contradict Hx2. +apply Rlt_not_eq. +apply Rlt_le_trans with (bpow (fexp n)). apply bpow_gt_0. -now apply generic_format_succ. -apply Rgt_not_eq. -now apply Rlt_le_trans with x. +apply round_ge_generic... +apply generic_format_bpow. +now apply valid_exp. +(* .. round up *) +apply Rlt_le_trans with (ulp x). +apply error_lt_ulp... +now apply Rgt_not_eq. +apply ulp_le_pos. +now left. +apply round_UP_pt... +Qed. + +(** allows both x and rnd x to be 0 *) +(* was ulp_half_error_f *) +Theorem error_le_half_ulp_round : + forall { Hm : Monotone_exp fexp }, + forall choice x, + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R. +Proof with auto with typeclass_instances. +intros Hm choice x. +case (Req_dec (round beta fexp (Znearest choice) x) 0); intros Hfx. +(* *) +case (Req_dec x 0); intros Hx. +apply Rle_trans with (1:=error_le_half_ulp _ _). +rewrite Hx, round_0... +right; ring. +generalize (error_le_half_ulp choice x). +rewrite Hfx. +unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp. +intros N. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +intros (H1,H2). +contradict Hfx. +apply round_neq_0_negligible_exp... +intros (n,(H1,Hn)); rewrite H1. +apply Rle_trans with (1:=N). +right; apply f_equal. +rewrite ulp_neq_0; trivial. +apply f_equal. +unfold canonic_exp. +apply valid_exp; trivial. +assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega]. +apply lt_bpow with beta. +destruct (ln_beta beta x) as (e,He). +simpl. +apply Rle_lt_trans with (Rabs x). +now apply He. +apply Rle_lt_trans with (Rabs (round beta fexp (Znearest choice) x - x)). +right; rewrite Hfx; unfold Rminus; rewrite Rplus_0_l. +apply sym_eq, Rabs_Ropp. +apply Rlt_le_trans with (ulp 0). +rewrite <- Hfx. +apply error_lt_ulp_round... +unfold ulp; rewrite Req_bool_true, H1; trivial. +now right. +(* *) +case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx. +(* . *) +case (Rle_or_lt 0 (round beta fexp Zfloor x)). +intros H; destruct H. +rewrite Hx at 2. +rewrite ulp_DN; trivial. +apply error_le_half_ulp. +rewrite Hx in Hfx; contradict Hfx; auto with real. +intros H. +apply Rle_trans with (1:=error_le_half_ulp _ _). +apply Rmult_le_compat_l. +auto with real. +apply ulp_le. +rewrite Hx; rewrite (Rabs_left1 x), Rabs_left; try assumption. +apply Ropp_le_contravar. +apply (round_DN_pt beta fexp x). +case (Rle_or_lt x 0); trivial. +intros H1; contradict H. +apply Rle_not_lt. +apply round_ge_generic... +apply generic_format_0. +now left. +(* . *) +case (Rle_or_lt 0 (round beta fexp Zceil x)). +intros H; destruct H. +apply Rle_trans with (1:=error_le_half_ulp _ _). +apply Rmult_le_compat_l. +auto with real. +apply ulp_le_pos; trivial. +case (Rle_or_lt 0 x); trivial. +intros H1; contradict H. +apply Rle_not_lt. +apply round_le_generic... +apply generic_format_0. +now left. +rewrite Hx; apply (round_UP_pt beta fexp x). +rewrite Hx in Hfx; contradict Hfx; auto with real. +intros H. +rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)). +rewrite <- round_DN_opp. +rewrite ulp_DN; trivial. +pattern x at 1 2; rewrite <- Ropp_involutive. +rewrite round_N_opp. +unfold Rminus. +rewrite <- Ropp_plus_distr, Rabs_Ropp. +apply error_le_half_ulp. +rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption. Qed. -Theorem lt_UP_le_DN : +Theorem pred_le: forall x y, + F x -> F y -> (x <= y)%R -> (pred x <= pred y)%R. +Proof. +intros x y Fx Fy Hxy. +assert (V:( ((x = 0) /\ (y = 0)) \/ (x <>0 \/ x < y))%R). +case (Req_dec x 0); intros Zx. +case Hxy; intros Zy. +now right; right. +left; split; trivial; now rewrite <- Zy. +now right; left. +destruct V as [(V1,V2)|V]. +rewrite V1,V2; now right. +apply le_pred_lt; try assumption. +apply generic_format_pred; try assumption. +case V; intros V1. +apply Rlt_le_trans with (2:=Hxy). +now apply pred_lt_id. +apply Rle_lt_trans with (2:=V1). +now apply pred_le_id. +Qed. + +Theorem succ_le: forall x y, + F x -> F y -> (x <= y)%R -> (succ x <= succ y)%R. +Proof. +intros x y Fx Fy Hxy. +rewrite 2!succ_eq_opp_pred_opp. +apply Ropp_le_contravar, pred_le; try apply generic_format_opp; try assumption. +now apply Ropp_le_contravar. +Qed. + +Theorem pred_le_inv: forall x y, F x -> F y + -> (pred x <= pred y)%R -> (x <= y)%R. +Proof. +intros x y Fx Fy Hxy. +rewrite <- (succ_pred x), <- (succ_pred y); try assumption. +apply succ_le; trivial; now apply generic_format_pred. +Qed. + +Theorem succ_le_inv: forall x y, F x -> F y + -> (succ x <= succ y)%R -> (x <= y)%R. +Proof. +intros x y Fx Fy Hxy. +rewrite <- (pred_succ x), <- (pred_succ y); try assumption. +apply pred_le; trivial; now apply generic_format_succ. +Qed. + +(* was lt_UP_le_DN *) +Theorem le_round_DN_lt_UP : forall x y, F y -> (y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R. Proof with auto with typeclass_instances. @@ -1178,26 +2100,58 @@ apply round_UP_pt... now apply Rlt_le. Qed. +(* was lt_DN_le_UP *) +Theorem round_UP_le_gt_DN : + forall x y, F y -> + (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R. +Proof with auto with typeclass_instances. +intros x y Fy Hlt. +apply round_UP_pt... +apply Rnot_lt_le. +contradict Hlt. +apply RIneq.Rle_not_lt. +apply round_DN_pt... +now apply Rlt_le. +Qed. + + + Theorem pred_UP_le_DN : - forall x, (0 < round beta fexp Zceil x)%R -> - (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R. + forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R. Proof with auto with typeclass_instances. -intros x Pxu. +intros x. destruct (generic_format_EM beta fexp x) as [Fx|Fx]. rewrite !round_generic... -now apply Rlt_le; apply pred_lt_id. +apply pred_le_id. +case (Req_dec (round beta fexp Zceil x) 0); intros Zx. +rewrite Zx; unfold pred; rewrite Ropp_0. +unfold succ; rewrite Rle_bool_true;[idtac|now right]. +rewrite Rplus_0_l; unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +intros (H1,H2). +contradict Zx; apply round_neq_0_negligible_exp... +intros L; apply Fx; rewrite L; apply generic_format_0. +intros (n,(H1,Hn)); rewrite H1. +case (Rle_or_lt (- bpow (fexp n)) (round beta fexp Zfloor x)); trivial; intros K. +absurd (round beta fexp Zceil x <= - bpow (fexp n))%R. +apply Rlt_not_le. +rewrite Zx, <- Ropp_0. +apply Ropp_lt_contravar, bpow_gt_0. +apply round_UP_le_gt_DN; try assumption. +apply generic_format_opp, generic_format_bpow. +now apply valid_exp. assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup. - now apply pred_lt_id. -apply lt_UP_le_DN... +now apply pred_lt_id. +apply le_round_DN_lt_UP... apply generic_format_pred... now apply round_UP_pt. Qed. Theorem pred_UP_eq_DN : - forall x, (0 < round beta fexp Zceil x)%R -> ~ F x -> + forall x, ~ F x -> (pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R. Proof with auto with typeclass_instances. -intros x Px Fx. +intros x Fx. apply Rle_antisym. now apply pred_UP_le_DN. apply le_pred_lt; try apply generic_format_round... @@ -1205,212 +2159,200 @@ pose proof round_DN_UP_lt _ _ _ Fx as HE. now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE). Qed. +Theorem succ_DN_eq_UP : + forall x, ~ F x -> + (succ (round beta fexp Zfloor x) = round beta fexp Zceil x)%R. +Proof with auto with typeclass_instances. +intros x Fx. +rewrite <- pred_UP_eq_DN; trivial. +rewrite succ_pred; trivial. +apply generic_format_round... +Qed. + + +(* was betw_eq_DN *) +Theorem round_DN_eq_betw: forall x d, F d + -> (d <= x < succ d)%R + -> round beta fexp Zfloor x = d. +Proof with auto with typeclass_instances. +intros x d Fd (Hxd1,Hxd2). +generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)). +apply sym_eq, Rle_antisym. +now apply T3. +destruct (generic_format_EM beta fexp x) as [Fx|NFx]. +rewrite round_generic... +apply succ_le_inv; try assumption. +apply succ_le_lt; try assumption. +apply generic_format_succ... +apply succ_le_inv; try assumption. +rewrite succ_DN_eq_UP; trivial. +apply round_UP_pt... +apply generic_format_succ... +now left. +Qed. + +(* was betw_eq_UP *) +Theorem round_UP_eq_betw: forall x u, F u + -> (pred u < x <= u)%R + -> round beta fexp Zceil x = u. +Proof with auto with typeclass_instances. +intros x u Fu Hux. +rewrite <- (Ropp_involutive (round beta fexp Zceil x)). +rewrite <- round_DN_opp. +rewrite <- (Ropp_involutive u). +apply f_equal. +apply round_DN_eq_betw; try assumption. +now apply generic_format_opp. +split;[now apply Ropp_le_contravar|idtac]. +rewrite succ_opp. +now apply Ropp_lt_contravar. +Qed. (** Properties of rounding to nearest and ulp *) -Theorem rnd_N_le_half_an_ulp: forall choice u v, - F u -> (0 < u)%R -> (v < u + (ulp u)/2)%R +Theorem round_N_le_midp: forall choice u v, + F u -> (v < (u + succ u)/2)%R -> (round beta fexp (Znearest choice) v <= u)%R. Proof with auto with typeclass_instances. -intros choice u v Fu Hu H. +intros choice u v Fu H. (* . *) -assert (0 < ulp u / 2)%R. -unfold Rdiv; apply Rmult_lt_0_compat. -unfold ulp; apply bpow_gt_0. -auto with real. -(* . *) -assert (ulp u / 2 < ulp u)%R. -apply Rlt_le_trans with (ulp u *1)%R;[idtac|right; ring]. -unfold Rdiv; apply Rmult_lt_compat_l. -apply bpow_gt_0. +assert (V: ((succ u = 0 /\ u = 0) \/ u < succ u)%R). +specialize (succ_ge_id u); intros P; destruct P as [P|P]. +now right. +case (Req_dec u 0); intros Zu. +left; split; trivial. +now rewrite <- P. +right; now apply succ_gt_id. +(* *) +destruct V as [(V1,V2)|V]. +rewrite V2; apply round_le_generic... +apply generic_format_0. +left; apply Rlt_le_trans with (1:=H). +rewrite V1,V2; right; field. +(* *) +assert (T: (u < (u + succ u) / 2 < succ u)%R). +split. apply Rmult_lt_reg_l with 2%R. -auto with real. -apply Rle_lt_trans with 1%R. +now auto with real. +apply Rplus_lt_reg_l with (-u)%R. +apply Rle_lt_trans with u;[right; ring|idtac]. +apply Rlt_le_trans with (1:=V). right; field. -rewrite Rmult_1_r; auto with real. +apply Rmult_lt_reg_l with 2%R. +now auto with real. +apply Rplus_lt_reg_l with (-succ u)%R. +apply Rle_lt_trans with u;[right; field|idtac]. +apply Rlt_le_trans with (1:=V). +right; ring. (* *) -apply Rnd_N_pt_monotone with F v (u + ulp u / 2)%R... +destruct T as (T1,T2). +apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R... apply round_N_pt... -apply Rnd_DN_pt_N with (u+ulp u)%R. -pattern u at 3; replace u with (round beta fexp Zfloor (u + ulp u / 2)). +apply Rnd_DN_pt_N with (succ u)%R. +pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)). apply round_DN_pt... -apply round_DN_succ; try assumption. +apply round_DN_eq_betw; trivial. split; try left; assumption. -replace (u+ulp u)%R with (round beta fexp Zceil (u + ulp u / 2)). +pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)). apply round_UP_pt... -apply round_UP_succ; try assumption... +apply round_UP_eq_betw; trivial. +apply generic_format_succ... +rewrite pred_succ; trivial. split; try left; assumption. right; field. Qed. -Theorem rnd_N_ge_half_an_ulp_pred: forall choice u v, - F u -> (0 < pred u)%R -> (u - (ulp (pred u))/2 < v)%R +Theorem round_N_ge_midp: forall choice u v, + F u -> ((u + pred u)/2 < v)%R -> (u <= round beta fexp (Znearest choice) v)%R. Proof with auto with typeclass_instances. -intros choice u v Fu Hu H. -(* . *) -assert (0 < u)%R. -apply Rlt_trans with (1:= Hu). -apply pred_lt_id. -assert (0 < ulp (pred u) / 2)%R. -unfold Rdiv; apply Rmult_lt_0_compat. -unfold ulp; apply bpow_gt_0. -auto with real. -assert (ulp (pred u) / 2 < ulp (pred u))%R. -apply Rlt_le_trans with (ulp (pred u) *1)%R;[idtac|right; ring]. -unfold Rdiv; apply Rmult_lt_compat_l. -apply bpow_gt_0. -apply Rmult_lt_reg_l with 2%R. -auto with real. -apply Rle_lt_trans with 1%R. -right; field. -rewrite Rmult_1_r; auto with real. -(* *) -apply Rnd_N_pt_monotone with F (u - ulp (pred u) / 2)%R v... -2: apply round_N_pt... -apply Rnd_UP_pt_N with (pred u). -pattern (pred u) at 2; replace (pred u) with (round beta fexp Zfloor (u - ulp (pred u) / 2)). -apply round_DN_pt... -replace (u - ulp (pred u) / 2)%R with (pred u + ulp (pred u) / 2)%R. -apply round_DN_succ; try assumption. -apply generic_format_pred; assumption. -split; [left|idtac]; assumption. -pattern u at 3; rewrite <- (pred_plus_ulp u); try assumption. -field. -now apply Rgt_not_eq. -pattern u at 3; replace u with (round beta fexp Zceil (u - ulp (pred u) / 2)). -apply round_UP_pt... -replace (u - ulp (pred u) / 2)%R with (pred u + ulp (pred u) / 2)%R. -apply trans_eq with (pred u +ulp(pred u))%R. -apply round_UP_succ; try assumption... -apply generic_format_pred; assumption. -split; [idtac|left]; assumption. -apply pred_plus_ulp; try assumption. -now apply Rgt_not_eq. -pattern u at 3; rewrite <- (pred_plus_ulp u); try assumption. -field. -now apply Rgt_not_eq. -pattern u at 4; rewrite <- (pred_plus_ulp u); try assumption. +intros choice u v Fu H. +rewrite <- (Ropp_involutive v). +rewrite round_N_opp. +rewrite <- (Ropp_involutive u). +apply Ropp_le_contravar. +apply round_N_le_midp. +now apply generic_format_opp. +apply Ropp_lt_cancel. +rewrite Ropp_involutive. +apply Rle_lt_trans with (2:=H). +unfold pred. right; field. -now apply Rgt_not_eq. Qed. -Theorem rnd_N_ge_half_an_ulp: forall choice u v, - F u -> (0 < u)%R -> (u <> bpow (ln_beta beta u - 1))%R - -> (u - (ulp u)/2 < v)%R - -> (u <= round beta fexp (Znearest choice) v)%R. +Lemma round_N_eq_DN: forall choice x, + let d:=round beta fexp Zfloor x in + let u:=round beta fexp Zceil x in + (x<(d+u)/2)%R -> + round beta fexp (Znearest choice) x = d. Proof with auto with typeclass_instances. -intros choice u v Fu Hupos Hu H. -(* *) -assert (bpow (ln_beta beta u-1) <= pred u)%R. -apply le_pred_lt; try assumption. -apply generic_format_bpow. -assert (canonic_exp beta fexp u < ln_beta beta u)%Z. -apply ln_beta_generic_gt; try assumption. -now apply Rgt_not_eq. -unfold canonic_exp in H0. -ring_simplify (ln_beta beta u - 1 + 1)%Z. -omega. -destruct ln_beta as (e,He); simpl in *. -assert (bpow (e - 1) <= Rabs u)%R. -apply He. -now apply Rgt_not_eq. -rewrite Rabs_right in H0. -case H0; auto. -intros T; contradict T. -now apply sym_not_eq. -apply Rle_ge; now left. -assert (Hu2:(ulp (pred u) = ulp u)). -unfold ulp, canonic_exp. -apply f_equal; apply f_equal. -apply ln_beta_unique. -rewrite Rabs_right. -split. -assumption. -apply Rlt_trans with (1:=pred_lt_id _). -destruct ln_beta as (e,He); simpl in *. -rewrite Rabs_right in He. -apply He. -now apply Rgt_not_eq. -apply Rle_ge; now left. -apply Rle_ge, pred_ge_0; assumption. -apply rnd_N_ge_half_an_ulp_pred; try assumption. -apply Rlt_le_trans with (2:=H0). -apply bpow_gt_0. -rewrite Hu2; assumption. +intros choice x d u H. +apply Rle_antisym. +destruct (generic_format_EM beta fexp x) as [Fx|Fx]. +rewrite round_generic... +apply round_DN_pt; trivial; now right. +apply round_N_le_midp. +apply round_DN_pt... +apply Rlt_le_trans with (1:=H). +right; apply f_equal2; trivial; apply f_equal. +now apply sym_eq, succ_DN_eq_UP. +apply round_ge_generic; try apply round_DN_pt... Qed. - -Lemma round_N_DN_betw: forall choice x d u, - Rnd_DN_pt (generic_format beta fexp) x d -> - Rnd_UP_pt (generic_format beta fexp) x u -> - (d<=x<(d+u)/2)%R -> +Lemma round_N_eq_DN_pt: forall choice x d u, + Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> + (x<(d+u)/2)%R -> round beta fexp (Znearest choice) x = d. Proof with auto with typeclass_instances. intros choice x d u Hd Hu H. -apply Rnd_N_pt_unicity with (generic_format beta fexp) x d u; try assumption. -intros Y. -absurd (x < (d+u)/2)%R; try apply H. -apply Rle_not_lt; right. -apply Rplus_eq_reg_r with (-x)%R. -apply trans_eq with (- (x-d)/2 + (u-x)/2)%R. -field. -rewrite Y; field. -apply round_N_pt... -apply Rnd_DN_UP_pt_N with d u... -apply Hd. -right; apply trans_eq with (-(d-x))%R;[idtac|ring]. -apply Rabs_left1. -apply Rplus_le_reg_l with x; ring_simplify. -apply H. -rewrite Rabs_left1. -apply Rplus_le_reg_l with (d+x)%R. -apply Rmult_le_reg_l with (/2)%R. -auto with real. -apply Rle_trans with x. -right; field. -apply Rle_trans with ((d+u)/2)%R. -now left. -right; field. -apply Rplus_le_reg_l with x; ring_simplify. -apply H. +assert (H0:(d = round beta fexp Zfloor x)%R). +apply Rnd_DN_pt_unicity with (1:=Hd). +apply round_DN_pt... +rewrite H0. +apply round_N_eq_DN. +rewrite <- H0. +rewrite Rnd_UP_pt_unicity with F x (round beta fexp Zceil x) u; try assumption. +apply round_UP_pt... Qed. +Lemma round_N_eq_UP: forall choice x, + let d:=round beta fexp Zfloor x in + let u:=round beta fexp Zceil x in + ((d+u)/2 < x)%R -> + round beta fexp (Znearest choice) x = u. +Proof with auto with typeclass_instances. +intros choice x d u H. +apply Rle_antisym. +apply round_le_generic; try apply round_UP_pt... +destruct (generic_format_EM beta fexp x) as [Fx|Fx]. +rewrite round_generic... +apply round_UP_pt; trivial; now right. +apply round_N_ge_midp. +apply round_UP_pt... +apply Rle_lt_trans with (2:=H). +right; apply f_equal2; trivial; rewrite Rplus_comm; apply f_equal2; trivial. +now apply pred_UP_eq_DN. +Qed. -Lemma round_N_UP_betw: forall choice x d u, - Rnd_DN_pt (generic_format beta fexp) x d -> - Rnd_UP_pt (generic_format beta fexp) x u -> - ((d+u)/2 < x <= u)%R -> +Lemma round_N_eq_UP_pt: forall choice x d u, + Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> + ((d+u)/2 < x)%R -> round beta fexp (Znearest choice) x = u. Proof with auto with typeclass_instances. intros choice x d u Hd Hu H. -rewrite <- (Ropp_involutive (round beta fexp (Znearest choice) x )), - <- (Ropp_involutive u) . -apply f_equal. -rewrite <- (Ropp_involutive x) . -rewrite round_N_opp, Ropp_involutive. -apply round_N_DN_betw with (-d)%R. -replace u with (round beta fexp Zceil x). -rewrite <- round_DN_opp. -apply round_DN_pt... -apply Rnd_UP_pt_unicity with (generic_format beta fexp) x... -apply round_UP_pt... -replace d with (round beta fexp Zfloor x). -rewrite <- round_UP_opp. +assert (H0:(u = round beta fexp Zceil x)%R). +apply Rnd_UP_pt_unicity with (1:=Hu). apply round_UP_pt... -apply Rnd_DN_pt_unicity with (generic_format beta fexp) x... +rewrite H0. +apply round_N_eq_UP. +rewrite <- H0. +rewrite Rnd_DN_pt_unicity with F x (round beta fexp Zfloor x) d; try assumption. apply round_DN_pt... -split. -apply Ropp_le_contravar, H. -apply Rlt_le_trans with (-((d + u) / 2))%R. -apply Ropp_lt_contravar, H. -unfold Rdiv; right; ring. Qed. - End Fcore_ulp. diff --git a/flocq/Flocq_version.v b/flocq/Flocq_version.v index d2d9d3fb..c391f590 100644 --- a/flocq/Flocq_version.v +++ b/flocq/Flocq_version.v @@ -25,7 +25,8 @@ Definition Flocq_version := Eval vm_compute in let fix parse s major minor := match s with | String "."%char t => parse t (major * 100 + minor)%N N0 - | String h t => parse t major (minor + N_of_ascii h - N_of_ascii "0"%char)%N + | String h t => + parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N | Empty_string => (major * 100 + minor)%N end in - parse "2.4.0"%string N0 N0. + parse "2.5.0"%string N0 N0. diff --git a/flocq/Prop/Fprop_div_sqrt_error.v b/flocq/Prop/Fprop_div_sqrt_error.v index ec00ca4e..9d29001d 100644 --- a/flocq/Prop/Fprop_div_sqrt_error.v +++ b/flocq/Prop/Fprop_div_sqrt_error.v @@ -95,9 +95,6 @@ intros e; apply Zle_refl. now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. (* *) destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). -apply Rmult_integral_contrapositive_currified. -exact Zx. -now apply Rinv_neq_0_compat. rewrite Heps2. rewrite <- Rabs_Ropp. replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. @@ -135,8 +132,11 @@ now apply Rabs_pos_lt. rewrite Rabs_Ropp. replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). rewrite <- Hr1. -apply ulp_error_f... -unfold ulp; apply f_equal. +apply error_lt_ulp_round... +apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. +rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. now rewrite Hr2, <- Hr1. replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. rewrite bpow_plus. @@ -246,8 +246,10 @@ apply Rmult_le_compat_r. apply Rabs_pos. apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. rewrite <- Hr1. -apply ulp_half_error_f... -right; unfold ulp; apply f_equal. +apply error_le_half_ulp_round... +right; rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. rewrite Hr2, <- Hr1; trivial. rewrite Rmult_assoc, Rmult_comm. replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. diff --git a/flocq/Prop/Fprop_mult_error.v b/flocq/Prop/Fprop_mult_error.v index e84e80b4..7c71627b 100644 --- a/flocq/Prop/Fprop_mult_error.v +++ b/flocq/Prop/Fprop_mult_error.v @@ -126,8 +126,9 @@ apply Zplus_le_compat_r. rewrite ln_beta_unique with (1 := Hexy). apply ln_beta_le_bpow with (1 := Hz). replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)). -apply ulp_error... -unfold ulp, canonic_exp. +apply error_lt_ulp... +rewrite ulp_neq_0; trivial. +unfold canonic_exp. now rewrite ln_beta_unique with (1 := Hexy). apply Hc1. reflexivity. diff --git a/flocq/Prop/Fprop_relative.v b/flocq/Prop/Fprop_relative.v index f0a8f344..585b71da 100644 --- a/flocq/Prop/Fprop_relative.v +++ b/flocq/Prop/Fprop_relative.v @@ -35,7 +35,7 @@ Section relative_error_conversion. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Lemma relative_error_lt_conversion' : +Lemma relative_error_lt_conversion : forall x b, (0 < b)%R -> (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R -> exists eps, @@ -62,19 +62,6 @@ rewrite Rinv_l with (1 := Hx0). now rewrite Rabs_R1, Rmult_1_r. Qed. -(* TODO: remove *) -Lemma relative_error_lt_conversion : - forall x b, (0 < b)%R -> - (Rabs (round beta fexp rnd x - x) < b * Rabs x)%R -> - exists eps, - (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R. -Proof. -intros x b Hb0 Hxb. -apply relative_error_lt_conversion'. -exact Hb0. -now intros _. -Qed. - Lemma relative_error_le_conversion : forall x b, (0 <= b)%R -> (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R -> @@ -113,16 +100,15 @@ Theorem relative_error : forall x, (bpow emin <= Rabs x)%R -> (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R. -Proof. +Proof with auto with typeclass_instances. intros x Hx. -apply Rlt_le_trans with (ulp beta fexp x)%R. -now apply ulp_error. -unfold ulp, canonic_exp. assert (Hx': (x <> 0)%R). -intros H. -apply Rlt_not_le with (2 := Hx). -rewrite H, Rabs_R0. -apply bpow_gt_0. +intros T; contradict Hx; rewrite T, Rabs_R0. +apply Rlt_not_le, bpow_gt_0. +apply Rlt_le_trans with (ulp beta fexp x)%R. +now apply error_lt_ulp... +rewrite ulp_neq_0; trivial. +unfold canonic_exp. destruct (ln_beta beta x) as (ex, He). simpl. specialize (He Hx'). @@ -150,6 +136,7 @@ Proof with auto with typeclass_instances. intros x Hx. apply relative_error_lt_conversion... apply bpow_gt_0. +intros _. now apply relative_error. Qed. @@ -168,28 +155,17 @@ rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. -Theorem relative_error_F2R_emin_ex' : +Theorem relative_error_F2R_emin_ex : forall m, let x := F2R (Float beta m emin) in exists eps, (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R. Proof with auto with typeclass_instances. intros m x. -apply relative_error_lt_conversion'... +apply relative_error_lt_conversion... apply bpow_gt_0. now apply relative_error_F2R_emin. Qed. -(* TODO: remove *) -Theorem relative_error_F2R_emin_ex : - forall m, let x := F2R (Float beta m emin) in - (x <> 0)%R -> - exists eps, - (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x _. -apply relative_error_F2R_emin_ex'. -Qed. - Theorem relative_error_round : (0 < p)%Z -> forall x, @@ -197,14 +173,13 @@ Theorem relative_error_round : (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R. Proof with auto with typeclass_instances. intros Hp x Hx. -apply Rlt_le_trans with (ulp beta fexp x)%R. -now apply ulp_error. assert (Hx': (x <> 0)%R). -intros H. -apply Rlt_not_le with (2 := Hx). -rewrite H, Rabs_R0. -apply bpow_gt_0. -unfold ulp, canonic_exp. +intros T; contradict Hx; rewrite T, Rabs_R0. +apply Rlt_not_le, bpow_gt_0. +apply Rlt_le_trans with (ulp beta fexp x)%R. +now apply error_lt_ulp. +rewrite ulp_neq_0; trivial. +unfold canonic_exp. destruct (ln_beta beta x) as (ex, He). simpl. specialize (He Hx'). @@ -222,7 +197,7 @@ apply bpow_ge_0. generalize He. apply round_abs_abs... clear rnd valid_rnd x Hx Hx' He. -intros rnd valid_rnd x Hx. +intros rnd valid_rnd x _ Hx. rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))). now apply round_le. apply generic_format_bpow. @@ -257,7 +232,7 @@ Theorem relative_error_N : Proof. intros x Hx. apply Rle_trans with (/2 * ulp beta fexp x)%R. -now apply ulp_half_error. +now apply error_le_half_ulp. rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. @@ -268,7 +243,8 @@ intros H. apply Rlt_not_le with (2 := Hx). rewrite H, Rabs_R0. apply bpow_gt_0. -unfold ulp, canonic_exp. +rewrite ulp_neq_0; trivial. +unfold canonic_exp. destruct (ln_beta beta x) as (ex, He). simpl. specialize (He Hx'). @@ -348,7 +324,7 @@ Theorem relative_error_N_round : Proof with auto with typeclass_instances. intros Hp x Hx. apply Rle_trans with (/2 * ulp beta fexp x)%R. -now apply ulp_half_error. +now apply error_le_half_ulp. rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. @@ -359,7 +335,8 @@ intros H. apply Rlt_not_le with (2 := Hx). rewrite H, Rabs_R0. apply bpow_gt_0. -unfold ulp, canonic_exp. +rewrite ulp_neq_0; trivial. +unfold canonic_exp. destruct (ln_beta beta x) as (ex, He). simpl. specialize (He Hx'). @@ -377,7 +354,7 @@ apply bpow_ge_0. generalize He. apply round_abs_abs... clear rnd valid_rnd x Hx Hx' He. -intros rnd valid_rnd x Hx. +intros rnd valid_rnd x _ Hx. rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))). now apply round_le. apply generic_format_bpow. @@ -428,17 +405,6 @@ Qed. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -(* TODO: remove *) -Theorem relative_error_FLT_F2R_emin : - forall m, let x := F2R (Float beta m (emin + prec - 1)) in - (x <> 0)%R -> - (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros m x Hx. -apply relative_error_F2R_emin... -apply relative_error_FLT_aux. -Qed. - Theorem relative_error_FLT : forall x, (bpow (emin + prec - 1) <= Rabs x)%R -> @@ -449,7 +415,7 @@ apply relative_error with (emin + prec - 1)%Z... apply relative_error_FLT_aux. Qed. -Theorem relative_error_FLT_F2R_emin' : +Theorem relative_error_FLT_F2R_emin : forall m, let x := F2R (Float beta m emin) in (x <> 0)%R -> (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. @@ -472,26 +438,13 @@ now exists (Float beta m emin). now apply relative_error_FLT. Qed. -Theorem relative_error_FLT_F2R_emin_ex' : +Theorem relative_error_FLT_F2R_emin_ex : forall m, let x := F2R (Float beta m emin) in exists eps, (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R. Proof with auto with typeclass_instances. intros m x. -apply relative_error_lt_conversion'... -apply bpow_gt_0. -now apply relative_error_FLT_F2R_emin'. -Qed. - -(* TODO: remove *) -Theorem relative_error_FLT_F2R_emin_ex : - forall m, let x := F2R (Float beta m (emin + prec - 1)) in - (x <> 0)%R -> - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x _. -apply relative_error_lt_conversion'... +apply relative_error_lt_conversion... apply bpow_gt_0. now apply relative_error_FLT_F2R_emin. Qed. @@ -506,7 +459,7 @@ Proof with auto with typeclass_instances. intros x Hx. apply relative_error_lt_conversion... apply bpow_gt_0. -now apply relative_error_FLT. +intros _; now apply relative_error_FLT. Qed. Variable choice : Z -> bool. @@ -548,7 +501,7 @@ apply relative_error_N_round with (emin + prec - 1)%Z... apply relative_error_FLT_aux. Qed. -Theorem relative_error_N_FLT_F2R_emin' : +Theorem relative_error_N_FLT_F2R_emin : forall m, let x := F2R (Float beta m emin) in (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. Proof with auto with typeclass_instances. @@ -573,17 +526,7 @@ now exists (Float beta m emin). now apply relative_error_N_FLT. Qed. -(* TODO: remove *) -Theorem relative_error_N_FLT_F2R_emin : - forall m, let x := F2R (Float beta m (emin + prec - 1)) in - (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_N_F2R_emin... -apply relative_error_FLT_aux. -Qed. - -Theorem relative_error_N_FLT_F2R_emin_ex' : +Theorem relative_error_N_FLT_F2R_emin_ex : forall m, let x := F2R (Float beta m emin) in exists eps, (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R. @@ -594,26 +537,11 @@ apply Rmult_le_pos. apply Rlt_le. apply (RinvN_pos 1). apply bpow_ge_0. -now apply relative_error_N_FLT_F2R_emin'. -Qed. - -(* TODO: remove *) -Theorem relative_error_N_FLT_F2R_emin_ex : - forall m, let x := F2R (Float beta m (emin + prec - 1)) in - exists eps, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. now apply relative_error_N_FLT_F2R_emin. Qed. -Theorem relative_error_N_FLT_round_F2R_emin' : + +Theorem relative_error_N_FLT_round_F2R_emin : forall m, let x := F2R (Float beta m emin) in (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R. Proof with auto with typeclass_instances. @@ -639,16 +567,6 @@ apply relative_error_N_round with (emin := (emin + prec - 1)%Z)... apply relative_error_FLT_aux. Qed. -(* TODO: remove *) -Theorem relative_error_N_FLT_round_F2R_emin : - forall m, let x := F2R (Float beta m (emin + prec - 1)) in - (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_N_round_F2R_emin... -apply relative_error_FLT_aux. -Qed. - Lemma error_N_FLT_aux : forall x, (0 < x)%R -> @@ -682,10 +600,11 @@ auto with real. apply bpow_ge_0. split. apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R. -apply ulp_half_error. +apply error_le_half_ulp. now apply FLT_exp_valid. apply Rmult_le_compat_l; auto with real. -unfold ulp. +rewrite ulp_neq_0. +2: now apply Rgt_not_eq. apply bpow_le. unfold FLT_exp, canonic_exp. rewrite Zmax_right. @@ -770,28 +689,17 @@ apply He. Qed. (** 1+#ε# property in any rounding in FLX *) -Theorem relative_error_FLX_ex' : +Theorem relative_error_FLX_ex : forall x, exists eps, (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. Proof with auto with typeclass_instances. intros x. -apply relative_error_lt_conversion'... +apply relative_error_lt_conversion... apply bpow_gt_0. now apply relative_error_FLX. Qed. -(* TODO: remove *) -Theorem relative_error_FLX_ex : - forall x, - (x <> 0)%R -> - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x _. -apply relative_error_FLX_ex'. -Qed. - Theorem relative_error_FLX_round : forall x, (x <> 0)%R -> diff --git a/ia32/AsmToJSON.ml b/ia32/AsmToJSON.ml index de39cb9d..3214491f 100644 --- a/ia32/AsmToJSON.ml +++ b/ia32/AsmToJSON.ml @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(* Simple functions to serialize powerpc Asm to JSON *) +(* Simple functions to serialize ia32 Asm to JSON *) (* Dummy function *) let p_program oc prog = diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml index baf0523e..4f02e633 100644 --- a/ia32/Asmexpand.ml +++ b/ia32/Asmexpand.ml @@ -387,36 +387,46 @@ let expand_instruction instr = end | _ -> emit instr -let expand_function fn = - try - set_current_function fn; - List.iter expand_instruction fn.fn_code; - Errors.OK (get_current_function ()) - with Error s -> - Errors.Error (Errors.msg (coqstring_of_camlstring s)) +let int_reg_to_dwarf = function + | EAX -> 0 + | EBX -> 3 + | ECX -> 1 + | EDX -> 2 + | ESI -> 6 + | EDI -> 7 + | EBP -> 5 + | ESP -> 4 -let expand_fundef = function - | Internal f -> - begin match expand_function f with - | Errors.OK tf -> Errors.OK (Internal tf) - | Errors.Error msg -> Errors.Error msg - end - | External ef -> - Errors.OK (External ef) +let float_reg_to_dwarf = function + | XMM0 -> 21 + | XMM1 -> 22 + | XMM2 -> 23 + | XMM3 -> 24 + | XMM4 -> 25 + | XMM5 -> 26 + | XMM6 -> 27 + | XMM7 -> 28 -let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program expand_fundef p -let expand_function fn = +let preg_to_dwarf = function + | IR r -> int_reg_to_dwarf r + | FR r -> float_reg_to_dwarf r + | _ -> assert false + + +let expand_function id fn = try set_current_function fn; - List.iter expand_instruction fn.fn_code; + if !Clflags.option_g then + expand_debug id 4 preg_to_dwarf expand_instruction fn.fn_code + else + List.iter expand_instruction fn.fn_code; Errors.OK (get_current_function ()) with Error s -> Errors.Error (Errors.msg (coqstring_of_camlstring s)) -let expand_fundef = function +let expand_fundef id = function | Internal f -> - begin match expand_function f with + begin match expand_function id f with | Errors.OK tf -> Errors.OK (Internal tf) | Errors.Error msg -> Errors.Error msg end @@ -424,4 +434,4 @@ let expand_fundef = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program expand_fundef p + AST.transform_partial_ident_program expand_fundef p diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index 439dd2b0..95de40ca 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -20,6 +20,7 @@ open AST open Memdata open Asm open PrintAsmaux +open Fileinfo module StringSet = Set.Make(String) @@ -101,8 +102,10 @@ module Cygwin_System : SYSTEM = | Section_user(s, wr, ex) -> sprintf ".section \"%s\", \"%s\"\n" s (if ex then "xr" else if wr then "d" else "dr") - | Section_debug_info - | Section_debug_abbrev -> "" (* Dummy value *) + | Section_debug_info _ -> ".section .debug_info,\"dr\"" + | Section_debug_loc -> ".section .debug_loc,\"dr\"" + | Section_debug_line _ -> ".section .debug_line,\"dr\"" + | Section_debug_abbrev -> ".section .debug_abbrev,\"dr\"" (* Dummy value *) let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) @@ -150,8 +153,10 @@ module ELF_System : SYSTEM = | Section_user(s, wr, ex) -> sprintf ".section \"%s\",\"a%s%s\",@progbits" s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info - | Section_debug_abbrev -> "" (* Dummy value *) + | Section_debug_info _ -> ".section .debug_info,\"\",@progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",@progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",@progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",@progbits" let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) @@ -202,8 +207,11 @@ module MacOS_System : SYSTEM = sprintf ".section \"%s\", %s, %s" (if wr then "__DATA" else "__TEXT") s (if ex then "regular, pure_instructions" else "regular") - | Section_debug_info - | Section_debug_abbrev -> "" (* Dummy value *) + | Section_debug_info _ -> ".section __DWARF,__debug_info,regular,debug" + | Section_debug_loc -> ".section __DWARF,__debug_loc,regular,debug" + | Section_debug_line _ -> ".section __DWARF,__debug_line,regular,debug" + | Section_debug_abbrev -> ".section __DWARF,__debug_abbrev,regular,debug" (* Dummy value *) + let stack_alignment = 16 (* mandatory *) @@ -741,9 +749,16 @@ module Target(System: SYSTEM):TARGET = let print_var_info = print_var_info - let print_prologue _ = - need_masks := false - + let print_prologue oc = + need_masks := false; + if !Clflags.option_g then begin + section oc Section_text; + let low_pc = new_label () in + Debug.add_compilation_section_start ".text" low_pc; + fprintf oc "%a:\n" elf_label low_pc; + fprintf oc " .cfi_sections .debug_frame\n" + end + let print_epilogue oc = if !need_masks then begin section oc (Section_const true); @@ -758,25 +773,22 @@ module Target(System: SYSTEM):TARGET = fprintf oc "%a: .long 0x7FFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF\n" raw_symbol "__abss_mask" end; - System.print_epilogue oc + System.print_epilogue oc; + if !Clflags.option_g then begin + let high_pc = new_label () in + Debug.add_compilation_section_end ".text" high_pc; + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + fprintf oc "%a:\n" elf_label high_pc + end let comment = comment let default_falignment = 16 - let get_start_addr () = -1 (* Dummy constant *) - - let get_end_addr () = -1 (* Dummy constant *) - - let get_stmt_list_addr () = -1 (* Dummy constant *) - - module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *) - let label = label let new_label = new_label - - let print_file_loc _ _ = () (* Dummy function *) end diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index 68c095f0..c50b3230 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -295,8 +295,7 @@ let intern_string s = next_atom := Pos.succ !next_atom; Hashtbl.add atom_of_string s a; Hashtbl.add string_of_atom a s; - a - + a let extern_atom a = try Hashtbl.find string_of_atom a diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index d82b9730..9d480ed5 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -337,9 +337,11 @@ let p_section oc = function | Section_string -> fprintf oc "{\"Section Name\":\"String\"}" | Section_literal -> fprintf oc "{\"Section Name\":\"Literal\"}" | Section_jumptable -> fprintf oc "{\"Section Name\":\"Jumptable\"}" - | Section_user (s,w,e) -> fprintf oc "{\"Section Name\":%s,\"Writable\":%B,\"Executable\":%B}" s w e - | Section_debug_info - | Section_debug_abbrev -> () (* There should be no info in the debug sections *) + | Section_user (s,w,e) -> fprintf oc "{\"Section Name\":\"%s\",\"Writable\":%B,\"Executable\":%B}" s w e + | Section_debug_info _ + | Section_debug_abbrev + | Section_debug_line _ + | Section_debug_loc -> () (* There should be no info in the debug sections *) let p_int_opt oc = function | None -> fprintf oc "0" diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 49f796ca..9e22e4e0 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -48,7 +48,7 @@ let emit_addimm rd rs n = List.iter emit (Asmgen.addimm rd rs n []) - + (* Handling of annotations *) let expand_annot_val txt targ args res = @@ -71,7 +71,7 @@ let expand_annot_val txt targ args res = Note that lfd and stfd cannot trap on ill-formed floats. *) let offset_in_range ofs = - Int.eq (Asmgen.high_s ofs) Int.zero + Int.eq (Asmgen.high_s ofs) _0 let memcpy_small_arg sz arg tmp = match arg with @@ -86,7 +86,7 @@ let memcpy_small_arg sz arg tmp = assert false let expand_builtin_memcpy_small sz al src dst = - let (tsrc, tdst) = + let (tsrc, tdst) = if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in @@ -124,7 +124,7 @@ let expand_builtin_memcpy_big sz al src dst = assert (sz >= 4); emit_loadimm GPR0 (Z.of_uint (sz / 4)); emit (Pmtctr GPR0); - let (s, d) = + let (s, d) = if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in memcpy_big_arg src s; memcpy_big_arg dst d; @@ -192,7 +192,7 @@ let rec expand_builtin_vload_common chunk base offset res = emit (Plwz(lo, offset', base)); emit (Plwz(hi, offset, base)) end - | None -> + | None -> emit (Paddi(GPR11, base, offset)); expand_builtin_vload_common chunk GPR11 (Cint _0) res end @@ -246,7 +246,7 @@ let expand_builtin_vstore_common chunk base offset src = | Some offset' -> emit (Pstw(hi, offset, base)); emit (Pstw(lo, offset', base)) - | None -> + | None -> let tmp = temp_for_vstore src in emit (Paddi(tmp, base, offset)); emit (Pstw(hi, Cint _0, tmp)); @@ -283,9 +283,9 @@ let expand_builtin_vstore chunk args = assert false (* Handling of varargs *) -let linkregister_offset = ref Int.zero +let linkregister_offset = ref _0 -let retaddr_offset = ref Int.zero +let retaddr_offset = ref _0 let current_function_stacksize = ref 0l @@ -448,8 +448,8 @@ let expand_builtin_inline name args res = emit (Picbi(GPR0,a1)) | "__builtin_dcbtls", [BA (IR a1); BA_int loc],_ -> if not ((Int.eq loc _0) || (Int.eq loc _2)) then - raise (Error "the second argument of __builtin_dcbtls must be a constant between 0 and 2"); - emit (Pdcbtls (loc,GPR0,a1)) + raise (Error "the second argument of __builtin_dcbtls must be 0 or 2"); + emit (Pdcbtls (loc,GPR0,a1)) | "__builtin_dcbtls",_,_ -> raise (Error "the second argument of __builtin_dcbtls must be a constant") | "__builtin_icbtls", [BA (IR a1); BA_int loc],_ -> @@ -482,7 +482,7 @@ let expand_builtin_inline name args res = raise (Error "the first argument of __builtin_set_spr must be a constant") (* Frame and return address *) | "__builtin_call_frame", _,BR (IR res) -> - let sz = !current_function_stacksize + let sz = !current_function_stacksize and ofs = !linkregister_offset in if sz < 0x8000l then emit (Paddi(res, GPR1, Cint(coqint_of_camlint sz))) @@ -510,6 +510,57 @@ let expand_builtin_inline name args res = end; emit (Por (res, res, GPR0)) end + (* atomic operations *) + | "__builtin_atomic_exchange", [BA (IR a1); BA (IR a2); BA (IR a3)],_ -> + emit (Plwz (GPR10,Cint _0,a2)); + emit (Psync); + let lbl = new_label() in + emit (Plabel lbl); + emit (Plwarx (GPR0,GPR0,a1)); + emit (Pstwcx_ (GPR10,GPR0,a1)); + emit (Pbf (CRbit_2,lbl)); + emit (Pisync); + emit (Pstw (GPR0,Cint _0,a3)) + | "__builtin_atomic_load", [BA (IR a1); BA (IR a2)],_ -> + let lbl = new_label () in + emit (Psync); + emit (Plwz (GPR0,Cint _0,a1)); + emit (Pcmpw (GPR0,GPR0)); + emit (Pbf (CRbit_2,lbl)); + emit (Plabel lbl); + emit (Pisync); + emit (Pstw (GPR0,Cint _0, a2)) + | "__builtin_sync_fetch_and_add", [BA (IR a1); BA(IR a2)], BR (IR res) -> + let lbl = new_label() in + emit (Psync); + emit (Plabel lbl); + emit (Plwarx (res,GPR0,a1)); + emit (Padd (GPR0,res,a2)); + emit (Pstwcx_ (GPR0,GPR0,a1)); + emit (Pbf (CRbit_2, lbl)); + emit (Pisync); + | "__builtin_atomic_compare_exchange", [BA (IR dst); BA(IR exp); BA (IR des)], BR (IR res) -> + let lbls = new_label () + and lblneq = new_label () + and lblsucc = new_label () in + emit (Plwz (GPR10,Cint _0,exp)); + emit (Plwz (GPR11,Cint _0,des)); + emit (Psync); + emit (Plabel lbls); + emit (Plwarx (GPR0,GPR0,dst)); + emit (Pcmpw (GPR0,GPR10)); + emit (Pbf (CRbit_2,lblneq)); + emit (Pstwcx_ (GPR11,GPR0,dst)); + emit (Pbf (CRbit_2,lbls)); + emit (Plabel lblneq); + (* Here, CR2 is true if the exchange succeeded, false if it failed *) + emit (Pisync); + emit (Pmfcr GPR10); + emit (Prlwinm (res,GPR10,(Z.of_uint 3),_1)); + (* Update exp with the current value of dst if the exchange failed *) + emit (Pbt (CRbit_2,lblsucc)); + emit (Pstw (GPR0,Cint _0,exp)); + emit (Plabel lblsucc) (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) @@ -540,7 +591,7 @@ let expand_instruction instr = | Pallocframe(sz, ofs,retofs) -> let variadic = (!current_function).fn_sig.sig_cc.cc_vararg in let sz = camlint_of_coqint sz in - assert (ofs = Int.zero); + assert (ofs = _0); let sz = if variadic then Int32.add sz 96l else sz in let adj = Int32.neg sz in if adj >= -0x8000l then @@ -635,17 +686,49 @@ let expand_instruction instr = | _ -> emit instr -let expand_function fn = +(* Translate to the integer identifier of the register as + the EABI specifies *) + +let int_reg_to_dwarf = function + | GPR0 -> 0 | GPR1 -> 1 | GPR2 -> 2 | GPR3 -> 3 + | GPR4 -> 4 | GPR5 -> 5 | GPR6 -> 6 | GPR7 -> 7 + | GPR8 -> 8 | GPR9 -> 9 | GPR10 -> 10 | GPR11 -> 11 + | GPR12 -> 12 | GPR13 -> 13 | GPR14 -> 14 | GPR15 -> 15 + | GPR16 -> 16 | GPR17 -> 17 | GPR18 -> 18 | GPR19 -> 19 + | GPR20 -> 20 | GPR21 -> 21 | GPR22 -> 22 | GPR23 -> 23 + | GPR24 -> 24 | GPR25 -> 25 | GPR26 -> 26 | GPR27 -> 27 + | GPR28 -> 28 | GPR29 -> 29 | GPR30 -> 30 | GPR31 -> 31 + +let float_reg_to_dwarf = function + | FPR0 -> 32 | FPR1 -> 33 | FPR2 -> 34 | FPR3 -> 35 + | FPR4 -> 36 | FPR5 -> 37 | FPR6 -> 38 | FPR7 -> 39 + | FPR8 -> 40 | FPR9 -> 41 | FPR10 -> 42 | FPR11 -> 43 + | FPR12 -> 44 | FPR13 -> 45 | FPR14 -> 46 | FPR15 -> 47 + | FPR16 -> 48 | FPR17 -> 49 | FPR18 -> 50 | FPR19 -> 51 + | FPR20 -> 52 | FPR21 -> 53 | FPR22 -> 54| FPR23 -> 55 + | FPR24 -> 56 | FPR25 -> 57 | FPR26 -> 58 | FPR27 -> 59 + | FPR28 -> 60 | FPR29 -> 61 | FPR30 -> 62 | FPR31 -> 63 + +let preg_to_dwarf = function + | IR r -> int_reg_to_dwarf r + | FR r -> float_reg_to_dwarf r + | _ -> assert false + + +let expand_function id fn = try set_current_function fn; - List.iter expand_instruction fn.fn_code; + if !Clflags.option_g then + expand_debug id 2 preg_to_dwarf expand_instruction fn.fn_code + else + List.iter expand_instruction fn.fn_code; Errors.OK (get_current_function ()) with Error s -> Errors.Error (Errors.msg (coqstring_of_camlstring s)) -let expand_fundef = function +let expand_fundef id = function | Internal f -> - begin match expand_function f with + begin match expand_function id f with | Errors.OK tf -> Errors.OK (Internal tf) | Errors.Error msg -> Errors.Error msg end @@ -653,4 +736,4 @@ let expand_fundef = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program expand_fundef p + AST.transform_partial_ident_program expand_fundef p diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml index 1bb8c6f7..a9e4f5e3 100644 --- a/powerpc/CBuiltins.ml +++ b/powerpc/CBuiltins.ml @@ -118,7 +118,16 @@ let builtins = { (TPtr (TVoid [],[]),[],false); (* isel *) "__builtin_isel", - (TInt (IInt, []),[TInt(IBool, []);TInt(IInt, []);TInt(IInt, [])],false) + (TInt (IInt, []),[TInt(IBool, []);TInt(IInt, []);TInt(IInt, [])],false); + (* atomic operations *) + "__builtin_atomic_exchange", + (TVoid [], [TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[])],false); + "__builtin_atomic_load", + (TVoid [], [TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[])],false); + "__builtin_atomic_compare_exchange", + (TInt (IBool, []), [TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[])],false); + "__builtin_sync_fetch_and_add", + (TInt (IInt, []), [TPtr (TInt(IInt, []),[]);TInt(IInt, [])],false); ] } diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v index e4006523..20bec532 100644 --- a/powerpc/Machregs.v +++ b/powerpc/Machregs.v @@ -160,9 +160,16 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := end end. +Definition builtin_atomic_exchange := ident_of_string "__builtin_atomic_exchange". +Definition builtin_sync_and_fetch := ident_of_string "__builtin_sync_fetch_and_add". +Definition builtin_atomic_compare_exchange := ident_of_string "__builtin_atomic_compare_exchange". + Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with - | EF_builtin _ _ => F13 :: nil + | EF_builtin id sg => + if ident_eq id builtin_atomic_exchange then R10::nil + else if ident_eq id builtin_atomic_compare_exchange then R10::R11::nil + else F13 :: nil | EF_vload _ => R11 :: nil | EF_vstore Mint64 => R10 :: R11 :: R12 :: nil | EF_vstore _ => R11 :: R12 :: nil @@ -183,8 +190,16 @@ Definition temp_for_parent_frame: mreg := Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). + Definition mregs_for_builtin (ef: external_function): list (option mreg) * list (option mreg) := - (nil, nil). + match ef with + | EF_builtin id sg => + if ident_eq id builtin_atomic_exchange then ((Some R3)::(Some R4)::(Some R5)::nil,nil) + else if ident_eq id builtin_sync_and_fetch then ((Some R4)::(Some R5)::nil,(Some R3)::nil) + else if ident_eq id builtin_atomic_compare_exchange then ((Some R4)::(Some R5)::(Some R6)::nil, (Some R3):: nil) + else (nil, nil) + | _ => (nil, nil) + end. Global Opaque destroyed_by_op destroyed_by_load destroyed_by_store diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index bc990de5..250686be 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -13,6 +13,7 @@ (* Printing PPC assembly code in asm syntax *) open Printf +open Fileinfo open Datatypes open Maps open Camlcoq @@ -39,7 +40,6 @@ module type SYSTEM = val cfi_rel_offset: out_channel -> string -> int32 -> unit val print_prologue: out_channel -> unit val print_epilogue: out_channel -> unit - val print_file_loc: out_channel -> DwarfTypes.file_loc -> unit val section: out_channel -> section_name -> unit val debug_section: out_channel -> section_name -> unit end @@ -72,12 +72,6 @@ let float_reg_name = function | FPR24 -> "24" | FPR25 -> "25" | FPR26 -> "26" | FPR27 -> "27" | FPR28 -> "28" | FPR29 -> "29" | FPR30 -> "30" | FPR31 -> "31" -let start_addr = ref (-1) - -let end_addr = ref (-1) - -let stmt_list_addr = ref (-1) - let label = elf_label module Linux_System : SYSTEM = @@ -129,9 +123,12 @@ module Linux_System : SYSTEM = | Section_user(s, wr, ex) -> sprintf ".section \"%s\",\"a%s%s\",@progbits" s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info -> ".debug_info,\"\",@progbits" - | Section_debug_abbrev -> ".debug_abbrev,\"\",@progbits" - + | Section_debug_info _ -> ".section .debug_info,\"\",@progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",@progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",@progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",@progbits\n" + + let section oc sec = let name = name_of_section sec in assert (name <> "COMM"); @@ -150,12 +147,25 @@ module Linux_System : SYSTEM = let cfi_rel_offset = cfi_rel_offset - let print_prologue oc = () + let print_prologue oc = + if !Clflags.option_g then begin + section oc Section_text; + let low_pc = new_label () in + Debug.add_compilation_section_start ".text" low_pc; + fprintf oc "%a:\n" label low_pc; + fprintf oc " .cfi_sections .debug_frame\n" + end - let print_epilogue oc = () + let print_epilogue oc = + if !Clflags.option_g then + begin + let high_pc = new_label () in + Debug.add_compilation_section_end ".text" high_pc; + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + fprintf oc "%a:\n" label high_pc + end - let print_file_loc _ _ = () - let debug_section _ _ = () end @@ -207,14 +217,21 @@ module Diab_System : SYSTEM = | true, false -> 'd' (* data *) | false, true -> 'c' (* text *) | false, false -> 'r') (* const *) - | Section_debug_info -> ".debug_info,,n" - | Section_debug_abbrev -> ".debug_abbrev,,n" + | Section_debug_info s -> sprintf ".section .debug_info%s,,n" (if s <> ".text" then s else "") + | Section_debug_abbrev -> ".section .debug_abbrev,,n" + | Section_debug_loc -> ".section .debug_loc,,n" + | Section_debug_line s -> sprintf ".section .debug_line.%s,,n\n" s let section oc sec = let name = name_of_section sec in assert (name <> "COMM"); - fprintf oc " %s\n" name - + match sec with + | Section_debug_info s -> + fprintf oc " %s\n" name; + if s <> ".text" then + fprintf oc " .sectionlink .debug_info\n" + | _ -> + fprintf oc " %s\n" name let print_file_line oc file line = print_file_line_d2 oc comment file line @@ -227,68 +244,51 @@ module Diab_System : SYSTEM = let cfi_adjust oc delta = () let cfi_rel_offset oc reg ofs = () + + let debug_section oc sec = + match sec with + | Section_debug_abbrev + | Section_debug_info _ + | Section_debug_loc -> () + | sec -> + let name = match sec with + | Section_user (name,_,_) -> name + | _ -> name_of_section sec in + if not (Debug.exists_section name) then + let line_start = new_label () + and low_pc = new_label () + and debug_info = new_label () in + Debug.add_diab_info name (line_start,debug_info,name_of_section sec); + Debug.add_compilation_section_start name low_pc; + let line_name = ".debug_line" ^(if name <> ".text" then name else "") in + fprintf oc " .section %s,,n\n" line_name; + if name <> ".text" then + fprintf oc " .sectionlink .debug_line\n"; + fprintf oc "%a:\n" label line_start; + section oc sec; + fprintf oc "%a:\n" label low_pc; + fprintf oc " .0byte %a\n" label debug_info; + fprintf oc " .d2_line_start %s\n" line_name + else + () let print_prologue oc = fprintf oc " .xopt align-fill-text=0x60000000\n"; - if !Clflags.option_g then - begin - fprintf oc " .text\n"; - fprintf oc " .section .debug_line,,n\n"; - let label_line_start = new_label () in - stmt_list_addr := label_line_start; - fprintf oc "%a:\n" label label_line_start; - fprintf oc " .text\n"; - let label_start = new_label () in - start_addr := label_start; - fprintf oc "%a:\n" label label_start; - fprintf oc " .d2_line_start .debug_line\n"; - end - - let filenum : (string,int) Hashtbl.t = Hashtbl.create 7 - - let additional_debug_sections: StringSet.t ref = ref StringSet.empty - + debug_section oc Section_text let print_epilogue oc = - if !Clflags.option_g then - begin - fprintf oc "\n"; - let label_end = new_label () in - end_addr := label_end; - fprintf oc "%a:\n" label label_end; - fprintf oc " .text\n"; - StringSet.iter (fun file -> - let label = new_label () in - Hashtbl.add filenum file label; - fprintf oc ".L%d: .d2filenum \"%s\"\n" label file) !all_files; - fprintf oc " .d2_line_end\n"; - StringSet.iter (fun s -> - fprintf oc " %s\n" s; - fprintf oc " .d2_line_end\n") !additional_debug_sections - end - - let print_file_loc oc (file,col) = - fprintf oc " .4byte %a\n" label (Hashtbl.find filenum file); - fprintf oc " .uleb128 %d\n" col - - let debug_section oc sec = - if !Clflags.option_g && Configuration.advanced_debug then - match sec with - | Section_user (name,_,_) -> - let sec_name = name_of_section sec in - if not (StringSet.mem sec_name !additional_debug_sections) then - begin - let name = ".debug_line"^name in - additional_debug_sections := StringSet.add sec_name !additional_debug_sections; - fprintf oc " .section %s,,n\n" name; - fprintf oc " .sectionlink .debug_line\n"; - section oc sec; - fprintf oc " .d2_line_start %s\n" name - end - | _ -> () (* Only the case of a user section is interresting *) - else - () - + let end_label sec = + fprintf oc "\n"; + fprintf oc " %s\n" sec; + let label_end = new_label () in + fprintf oc "%a:\n" label label_end; + label_end + and entry_label f = + let label = new_label () in + fprintf oc ".L%d: .d2filenum \"%s\"\n" label f; + label + and end_line () = fprintf oc " .d2_line_end\n" in + Debug.compute_diab_file_enum end_label entry_label end_line end @@ -865,21 +865,12 @@ module Target (System : SYSTEM):TARGET = end let default_falignment = 4 - - let get_start_addr () = !start_addr - - let get_end_addr () = !end_addr - - let get_stmt_list_addr () = !stmt_list_addr - - module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs let new_label = new_label let section oc sec = section oc sec; debug_section oc sec - end let sel_target () = diff --git a/test/c/aes.c b/test/c/aes.c index abdaf6c3..88b3de4a 100644 --- a/test/c/aes.c +++ b/test/c/aes.c @@ -1423,7 +1423,7 @@ static void do_test(int keybits, u8 * key, static void do_bench(int nblocks) { u32 ckey[4 * (MAXNR + 1)]; - u8 temp[16]; + u8 temp[16] = "Plaintext"; int nr; nr = rijndaelKeySetupEnc(ckey, (u8 *)"\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F", 128); diff --git a/test/regression/Makefile b/test/regression/Makefile index 2f70c63a..6ef44b78 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -17,7 +17,8 @@ TESTS=int32 int64 floats floats-basics \ volatile1 volatile2 volatile3 \ funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \ sizeof1 sizeof2 binops bool for1 switch switch2 compound \ - decl1 interop1 bitfields9 ptrs3 + decl1 interop1 bitfields9 ptrs3 \ + parsing # Can run, but only in compiled mode, and have reference output in Results diff --git a/test/regression/Results/parsing b/test/regression/Results/parsing new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/test/regression/Results/parsing diff --git a/test/regression/alias.c b/test/regression/alias.c index a38e6dfd..9887ae2b 100644 --- a/test/regression/alias.c +++ b/test/regression/alias.c @@ -1,8 +1,8 @@ /* Testing the alias analysis on ill-defined codes where it should remain conservative. */ -typedef unsigned int uintptr_t; -typedef signed int ptrdiff_t; +#include <stddef.h> +#include <stdint.h> /* For testing with GCC */ #define NOINLINE __attribute__((noinline)) diff --git a/test/regression/builtins-arm.c b/test/regression/builtins-arm.c index 91a8e890..643c8f1a 100644 --- a/test/regression/builtins-arm.c +++ b/test/regression/builtins-arm.c @@ -23,7 +23,10 @@ int main(int argc, char ** argv) y = 0; __builtin_write32_reversed(&y, 0x12345678); printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR"); - + /* Make sure that ignoring the result of a builtin + doesn't cause an internal error */ + (void) __builtin_bswap(x); + (void) __builtin_fsqrt(a); return 0; } diff --git a/test/regression/builtins-ia32.c b/test/regression/builtins-ia32.c index 10426209..558c3153 100644 --- a/test/regression/builtins-ia32.c +++ b/test/regression/builtins-ia32.c @@ -36,7 +36,10 @@ int main(int argc, char ** argv) y = 0; __builtin_write32_reversed(&y, 0x12345678); printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR"); - + /* Make sure that ignoring the result of a builtin + doesn't cause an internal error */ + (void) __builtin_bswap(x); + (void) __builtin_fsqrt(a); return 0; } diff --git a/test/regression/builtins-powerpc.c b/test/regression/builtins-powerpc.c index acffa435..90030737 100644 --- a/test/regression/builtins-powerpc.c +++ b/test/regression/builtins-powerpc.c @@ -50,7 +50,10 @@ int main(int argc, char ** argv) y = 0; __builtin_write32_reversed(&y, 0x12345678); printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR"); - + /* Make sure that ignoring the result of a builtin + doesn't cause an internal error */ + (void) __builtin_bswap(x); + (void) __builtin_fsqrt(a); return 0; } diff --git a/test/regression/parsing.c b/test/regression/parsing.c new file mode 100644 index 00000000..24b954c1 --- /dev/null +++ b/test/regression/parsing.c @@ -0,0 +1,104 @@ +#include<stdio.h> + +typedef signed int T; + +T f(T(T)); +T f(T a(T)) { + T b; + return 1; +} +int g(int x) { + T:; + T y; + T T; + T=1; + + return 1; +} + +void h() { + for(int T; ;) + if(1) + ; + T *x; + x = 0; +} + +void h2() { + for(int T; ;) + if(1) + ; + else T; +} + +struct S { + const T:3; + unsigned T:3; + const T:3; +}; + +void i() { + struct S s; + s.T = -1; + if(s.T < 0) printf("ERROR i\n"); +} + +/* These ones are parsed correctly, but rejected by the elaborator. */ +/* void j() { */ +/* typedef int I; */ +/* {sizeof(enum{I=2}); return I;} */ +/* {do sizeof(enum{I=2}); while((I)1);} */ +/* {if(1) return sizeof(enum{I=2}); */ +/* else return (I)1;} */ +/* {if(sizeof(enum{I=2})) return I; */ +/* else return I;} */ +/* {sizeof(enum{I=2})+I;} */ +/* {for(int i = sizeof(enum{I=2}); I; I) I; (I)1;} */ +/* } */ +/* int f2(enum{I=2} x) { */ +/* return I; */ +/* } */ +/* void k(A, B) */ +/* int B; */ +/* int A[B]; */ +/* { } */ +/* int l(A) */ +/* enum {T=1} A; */ +/* { return T * A; } */ + +void m() { + if(0) + if(1); + else printf("ERROR m\n"); + if(0) + for(int i; ; ) + if(1); + else printf("ERROR m\n"); + if(0) + for(1; ; ) + if(1); + else printf("ERROR m\n"); + if(0) + while(1) + if(1); + else printf("ERROR m\n"); + if(0) + L: if(1); + else printf("ERROR m\n"); + + if(0) + LL:for(1;;) + for(int i;;) + while(1) + switch(1) + case 1: + if(1); + else printf("ERROR m\n"); +} + +int main () { + f(g); + i(); + m(); + return 0; +} |