diff options
author | Bernhard Schommer <bernhardschommer@gmail.com> | 2015-10-20 14:45:56 +0200 |
---|---|---|
committer | Bernhard Schommer <bernhardschommer@gmail.com> | 2015-10-20 14:45:56 +0200 |
commit | ed6043fe910f7a320f7af6d3f9d35f39f5cf7ee1 (patch) | |
tree | 3fab134f5444f0472a1ff8c06e5b7686a40648dc | |
parent | 4d542bc7eafadb16b845cf05d1eb4988eb55ed0f (diff) | |
parent | 8a95c3e07fd02eaa87f8cca447bc7d7c2642eb22 (diff) | |
download | compcert-kvx-ed6043fe910f7a320f7af6d3f9d35f39f5cf7ee1.tar.gz compcert-kvx-ed6043fe910f7a320f7af6d3f9d35f39f5cf7ee1.zip |
Merge remote-tracking branch 'origin/master' into named-externals
Conflicts:
arm/TargetPrinter.ml
backend/CMparser.mly
backend/SelectLongproof.v
backend/Selectionproof.v
cfrontend/C2C.ml
checklink/Asm_printers.ml
checklink/Check.ml
checklink/Fuzz.ml
common/AST.v
debug/DebugInformation.ml
debug/DebugInit.ml
debug/DwarfPrinter.ml
debug/DwarfTypes.mli
debug/Dwarfgen.ml
exportclight/ExportClight.ml
ia32/TargetPrinter.ml
powerpc/Asm.v
powerpc/SelectOpproof.v
powerpc/TargetPrinter.ml
73 files changed, 2106 insertions, 7292 deletions
@@ -14,8 +14,6 @@ ccomp ccomp.byte ccomp.prof -cchecklink -cchecklink.byte clightgen clightgen.byte tools/ndfun @@ -39,6 +37,7 @@ cparser/Parser.v cparser/Lexer.ml cparser/pre_parser.ml cparser/pre_parser.mli +cparser/pre_parser.automaton lib/Readconfig.ml lib/Tokenize.ml driver/Version.ml diff --git a/Makefile.extr b/Makefile.extr index 1bb3eec8..77b6880e 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -17,23 +17,13 @@ include Makefile.config -# Directories containing plain Caml code (no preprocessing) +# Directories containing plain Caml code DIRS=extraction \ lib common $(ARCH) backend cfrontend cparser driver \ exportclight debug -# Directories containing Caml code that must be preprocessed by Camlp4 - -ifeq ($(CCHECKLINK),true) -DIRS_P4=checklink -else -DIRS_P4= -endif - -ALLDIRS=$(DIRS) $(DIRS_P4) - -INCLUDES=$(patsubst %,-I %, $(ALLDIRS)) +INCLUDES=$(patsubst %,-I %, $(DIRS)) # Control of warnings: # warning 3 = deprecated feature. Turned off for OCaml 4.02 (bytes vs strings) @@ -45,10 +35,6 @@ extraction/%.cmo: WARNINGS +=-w -20 COMPFLAGS=-g $(INCLUDES) $(WARNINGS) -# Using the bitstring library and syntax extension (for checklink) - -BITSTRING=-package bitstring,bitstring.syntax -syntax bitstring.syntax,camlp4o - # Using .opt compilers if available ifeq ($(OCAML_OPT_COMP),true) @@ -57,19 +43,10 @@ else DOTOPT= endif -# Compilers used for non-preprocessed code - OCAMLC=ocamlc$(DOTOPT) $(COMPFLAGS) OCAMLOPT=ocamlopt$(DOTOPT) $(COMPFLAGS) OCAMLDEP=ocamldep$(DOTOPT) -slash $(INCLUDES) -# Compilers used for Camlp4-preprocessed code. Note that we cannot -# use the .opt compilers (because ocamlfind doesn't support them). - -OCAMLC_P4=ocamlfind ocamlc $(COMPFLAGS) $(BITSTRING) -OCAMLOPT_P4=ocamlfind ocamlopt $(COMPFLAGS) $(BITSTRING) -OCAMLDEP_P4=ocamlfind ocamldep $(INCLUDES) $(BITSTRING) - MENHIR=menhir --explain OCAMLLEX=ocamllex -q MODORDER=tools/modorder .depend.extr @@ -98,20 +75,6 @@ ccomp.byte: $(CCOMP_OBJS:.cmx=.cmo) @echo "Linking $@" @$(OCAMLC) -o $@ $(LIBS:.cmxa=.cma) $+ -ifeq ($(CCHECKLINK),true) - -CCHECKLINK_OBJS:=$(shell $(MODORDER) checklink/Validator.cmx) - -cchecklink: $(CCHECKLINK_OBJS) - @echo "Linking $@" - @$(OCAMLOPT_P4) -linkpkg -o $@ $(CHECKLINK_LIBS) $+ - -cchecklink.byte: $(CCHECKLINK_OBJS:.cmx=.cmo) - @echo "Linking $@" - @$(OCAMLC_P4) -linkpkg -o $@ $(CHECKLINK_LIBS:.cmxa=.cma) $+ - -endif - CLIGHTGEN_OBJS:=$(shell $(MODORDER) exportclight/Clightgen.cmx) clightgen: $(CLIGHTGEN_OBJS) @@ -128,16 +91,6 @@ endif # End of part that assumes .depend.extr already exists -checklink/%.cmi: checklink/%.mli - @echo "OCAMLC $<" - @$(OCAMLC_P4) -c $< -checklink/%.cmo: checklink/%.ml - @echo "OCAMLC $<" - @$(OCAMLC_P4) -c $< -checklink/%.cmx: checklink/%.ml - @echo "OCAMLOPT $<" - @$(OCAMLOPT_P4) -c $< - %.cmi: %.mli @echo "OCAMLC $<" @$(OCAMLC) -c $< @@ -156,15 +109,12 @@ checklink/%.cmx: checklink/%.ml clean: rm -f $(EXECUTABLES) rm -f $(GENERATED) - for d in $(ALLDIRS); do rm -f $$d/*.cm[iox] $$d/*.o; done + for d in $(DIRS); do rm -f $$d/*.cm[iox] $$d/*.o; done # Generation of .depend.extr depend: $(GENERATED) @echo "Analyzing OCaml dependencies" @$(OCAMLDEP) $(foreach d,$(DIRS),$(wildcard $(d)/*.mli $(d)/*.ml)) $(GENERATED) >.depend.extr || { rm -f .depend.extr; exit 2; } -ifneq ($(strip $(DIRS_P4)),) - @$(OCAMLDEP_P4) $(foreach d,$(DIRS_P4),$(wildcard $(d)/*.mli $(d)/*.ml)) >>.depend.extr || { rm -f .depend.extr; exit 2; } -endif diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index a938725a..9f2c66cf 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -157,7 +157,8 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" - + | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1" let section oc sec = fprintf oc " %s\n" (name_of_section sec) @@ -901,21 +902,15 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = 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 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 + end let default_falignment = 4 diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index 7b8cc8c2..3d1dd754 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -94,8 +94,7 @@ let expand_debug id sp preg simple l = 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 @@ -133,6 +132,7 @@ let expand_debug id sp preg simple l = | _ -> aux None scopes rest end + | (Plabel lbl)::rest -> simple (Plabel lbl); aux (Some lbl) scopes rest | 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 diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index e7c945e3..6c1eda57 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -24,10 +24,10 @@ open TargetPrinter module Printer(Target:TARGET) = struct - let get_fun_addr name = + let get_fun_addr name txt = let s = Target.new_label () and e = Target.new_label () in - Debug.add_fun_addr name (e,s); + Debug.add_fun_addr name txt (e,s); s,e let print_debug_label oc l = @@ -51,7 +51,7 @@ module Printer(Target:TARGET) = fprintf oc " .globl %a\n" Target.symbol name; Target.print_optional_fun_info oc; let s,e = if !Clflags.option_g && Configuration.advanced_debug then - get_fun_addr name + get_fun_addr name text else -1,-1 in print_debug_label oc s; @@ -112,8 +112,8 @@ module Printer(Target:TARGET) = struct let label = Target.label let section = Target.section - let name_of_section = Target.name_of_section let symbol = Target.symbol + let comment = Target.comment end module DebugPrinter = DwarfPrinter (DwarfTarget) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 4835f785..a2db0915 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1060,7 +1060,7 @@ let convertFundef loc env fd = fd.fd_locals 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'; + Debug.atom_global fd.fd_name id'; Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; a_alignment = None; @@ -1127,7 +1127,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'; + Debug.atom_global 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/checklink/Asm_printers.ml b/checklink/Asm_printers.ml deleted file mode 100644 index 112c72d0..00000000 --- a/checklink/Asm_printers.ml +++ /dev/null @@ -1,321 +0,0 @@ -open Camlcoq -open Asm -open AST -open Library - -let string_of_pos p = Z.to_string (Z.Zpos p) -let string_of_coq_Z = Z.to_string -let string_of_ident = string_of_pos -let string_of_label = string_of_pos -let string_of_iint = string_of_coq_Z - -let string_of_ireg = function -| GPR0 -> "GPR0" -| GPR1 -> "GPR1" -| GPR2 -> "GPR2" -| GPR3 -> "GPR3" -| GPR4 -> "GPR4" -| GPR5 -> "GPR5" -| GPR6 -> "GPR6" -| GPR7 -> "GPR7" -| GPR8 -> "GPR8" -| GPR9 -> "GPR9" -| GPR10 -> "GPR10" -| GPR11 -> "GPR11" -| GPR12 -> "GPR12" -| GPR13 -> "GPR13" -| GPR14 -> "GPR14" -| GPR15 -> "GPR15" -| GPR16 -> "GPR16" -| GPR17 -> "GPR17" -| GPR18 -> "GPR18" -| GPR19 -> "GPR19" -| GPR20 -> "GPR20" -| GPR21 -> "GPR21" -| GPR22 -> "GPR22" -| GPR23 -> "GPR23" -| GPR24 -> "GPR24" -| GPR25 -> "GPR25" -| GPR26 -> "GPR26" -| GPR27 -> "GPR27" -| GPR28 -> "GPR28" -| GPR29 -> "GPR29" -| GPR30 -> "GPR30" -| GPR31 -> "GPR31" - -let string_of_freg = function -| FPR0 -> "FPR0" -| FPR1 -> "FPR1" -| FPR2 -> "FPR2" -| FPR3 -> "FPR3" -| FPR4 -> "FPR4" -| FPR5 -> "FPR5" -| FPR6 -> "FPR6" -| FPR7 -> "FPR7" -| FPR8 -> "FPR8" -| FPR9 -> "FPR9" -| FPR10 -> "FPR10" -| FPR11 -> "FPR11" -| FPR12 -> "FPR12" -| FPR13 -> "FPR13" -| FPR14 -> "FPR14" -| FPR15 -> "FPR15" -| FPR16 -> "FPR16" -| FPR17 -> "FPR17" -| FPR18 -> "FPR18" -| FPR19 -> "FPR19" -| FPR20 -> "FPR20" -| FPR21 -> "FPR21" -| FPR22 -> "FPR22" -| FPR23 -> "FPR23" -| FPR24 -> "FPR24" -| FPR25 -> "FPR25" -| FPR26 -> "FPR26" -| FPR27 -> "FPR27" -| FPR28 -> "FPR28" -| FPR29 -> "FPR29" -| FPR30 -> "FPR30" -| FPR31 -> "FPR31" - -let string_of_preg = function -| IR (i0) -> "IR(" ^ string_of_ireg i0 ^ ")" -| FR (f0) -> "FR(" ^ string_of_freg f0 ^ ")" -| PC -> "PC" -| LR -> "LR" -| CTR -> "CTR" -| CARRY -> "CARRY" -| CR0_0 -> "CR0_0" -| CR0_1 -> "CR0_1" -| CR0_2 -> "CR0_2" -| CR0_3 -> "CR0_3" -| CR1_2 -> "CR1_2" - -let string_of_external_function e = - match e with - | EF_builtin(name, sg) -> "EF_builtin" - | EF_vload(chunk) -> "EF_vload" - | EF_vstore(chunk) -> "EF_vstore" - | EF_vload_global(_, _, _) -> "EF_vload_global" - | EF_vstore_global(_, _, _) -> "EF_vstore_global" - | EF_malloc -> "EF_malloc" - | EF_free -> "EF_free" - | EF_memcpy(sz, al) -> - "EF_memcpy(" ^ string_of_z sz ^ ", " ^ string_of_z al ^ ")" - | EF_annot(_, _) -> "EF_annot" - | EF_annot_val(txt, targ) -> "EF_annot_val" - | _ -> "UNKNOWN" - -let string_of_constant = function -| Cint (i0) -> "Cint(" ^ string_of_iint i0 ^ ")" -| Csymbol_low (i0, i1) -> "Csymbol_low(" ^ string_of_ident i0 ^ ", " ^ string_of_iint i1 ^ ")" -| Csymbol_high (i0, i1) -> "Csymbol_high(" ^ string_of_ident i0 ^ ", " ^ string_of_iint i1 ^ ")" -| Csymbol_sda (i0, i1) -> "Csymbol_sda(" ^ string_of_ident i0 ^ ", " ^ string_of_iint i1 ^ ")" -| Csymbol_rel_low (i0, i1) -> "Csymbol_rel_low(" ^ string_of_ident i0 ^ ", " ^ string_of_iint i1 ^ ")" -| Csymbol_rel_high (i0, i1) -> "Csymbol_rel_high(" ^ string_of_ident i0 ^ ", " ^ string_of_iint i1 ^ ")" - -let string_of_crbit = function -| CRbit_0 -> "CRbit_0" -| CRbit_1 -> "CRbit_1" -| CRbit_2 -> "CRbit_2" -| CRbit_3 -> "CRbit_3" -| CRbit_6 -> "CRbit_6" - -let string_of_memory_chunk = function - | Mint8signed -> "int8s" - | Mint8unsigned -> "int8u" - | Mint16signed -> "int16s" - | Mint16unsigned -> "int16u" - | Mint32 -> "int32" - | Mint64 -> "int64" - | Mfloat32 -> "float32" - | Mfloat64 -> "float64" - | Many32 -> "any32" - | Many64 -> "any64" - -let rec string_of_annot_param sp_reg_name = function - | AA_base x -> string_of_preg x - | AA_int n -> Printf.sprintf "%ld" (camlint_of_coqint n) - | AA_long n -> Printf.sprintf "%Ld" (camlint64_of_coqint n) - | AA_float n -> Printf.sprintf "%.18g" (camlfloat_of_coqfloat n) - | AA_single n -> Printf.sprintf "%.18g" (camlfloat_of_coqfloat32 n) - | AA_loadstack(chunk, ofs) -> - Printf.sprintf "mem(%s + %ld, %s)" - sp_reg_name - (camlint_of_coqint ofs) - ((string_of_memory_chunk chunk)) - | AA_addrstack ofs -> - Printf.sprintf "(%s + %ld)" - sp_reg_name - (camlint_of_coqint ofs) - | AA_loadglobal(chunk, id, ofs) -> - Printf.sprintf "mem(\"%s\" + %ld, %s)" - (extern_atom id) - (camlint_of_coqint ofs) - (string_of_memory_chunk chunk) - | AA_addrglobal(id, ofs) -> - Printf.sprintf "(\"%s\" + %ld)" - (extern_atom id) - (camlint_of_coqint ofs) - | AA_longofwords(hi, lo) -> - Printf.sprintf "(%s * 0x100000000 + %s)" - (string_of_annot_param sp_reg_name hi) - (string_of_annot_param sp_reg_name lo) - -let string_of_instruction = function -| Padd (i0, i1, i2) -> "Padd(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Paddc (i0, i1, i2) -> "Paddc(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Padde (i0, i1, i2) -> "Padde(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Paddi (i0, i1, c2) -> "Paddi(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Paddic (i0, i1, c2) -> "Paddic(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Paddis (i0, i1, c2) -> "Paddis(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Paddze (i0, i1) -> "Paddze(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pallocframe(c0, i1) -> "Pallocframe(" ^ string_of_coq_Z c0 ^ ", " ^ string_of_iint i1 ^ ")" -| Pand_ (i0, i1, i2) -> "Pand_(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pandc (i0, i1, i2) -> "Pandc(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pandi_ (i0, i1, c2) -> "Pandi_(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Pandis_ (i0, i1, c2) -> "Pandis_(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Pb (l0) -> "Pb(" ^ string_of_label l0 ^ ")" -| Pbctr sg -> "Pbctr" -| Pbctrl sg -> "Pbctrl" -| Pbdnz (l1) -> "Pbdnz(" ^ string_of_label l1 ^ ")" -| Pbf (c0, l1) -> "Pbf(" ^ string_of_crbit c0 ^ ", " ^ string_of_label l1 ^ ")" -| Pbl (i0, sg) -> "Pbl(" ^ string_of_ident i0 ^ ")" -| Pbs (i0, sg) -> "Pbs(" ^ string_of_ident i0 ^ ")" -| Pblr -> "Pblr" -| Pbt (c0, l1) -> "Pbt(" ^ string_of_crbit c0 ^ ", " ^ string_of_label l1 ^ ")" -| Pbtbl (i0, l1) -> "Pbtbl(" ^ string_of_ireg i0 ^ ", " ^ string_of_list string_of_label ", " l1 ^ ")" -| Pcmplw (i0, i1) -> "Pcmplw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pcmplwi (i0, c1) -> "Pcmplwi(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ")" -| Pcmpw (i0, i1) -> "Pcmpw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pcmpwi (i0, c1) -> "Pcmpwi(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ")" -| Pcntlzw (i0, i1) -> "Pcntlzw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pcreqv (c0, c1, c2) -> "Pcreqv(" ^ string_of_crbit c0 ^ ", " ^ string_of_crbit c1 ^ ", " ^ string_of_crbit c2 ^ ")" -| Pcror (c0, c1, c2) -> "Pcror(" ^ string_of_crbit c0 ^ ", " ^ string_of_crbit c1 ^ ", " ^ string_of_crbit c2 ^ ")" -| Pcrxor (c0, c1, c2) -> "Pcrxor(" ^ string_of_crbit c0 ^ ", " ^ string_of_crbit c1 ^ ", " ^ string_of_crbit c2 ^ ")" -| Pdivw (i0, i1, i2) -> "Pdivw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pdivwu (i0, i1, i2) -> "Pdivwu(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Peieio -> "Peieio" -| Peqv (i0, i1, i2) -> "Peqv(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pextsb (i0, i1) -> "Pextsb(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pextsh (i0, i1) -> "Pextsh(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pfreeframe(c0, i1) -> "Pfreeframe(" ^ string_of_coq_Z c0 ^ ", " ^ string_of_iint i1 ^ ")" -| Pfabs (f0, f1) -> "Pfabs(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfabss (f0, f1) -> "Pfabss(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfadd (f0, f1, f2) -> "Pfadd(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfadds (f0, f1, f2) -> "Pfadds(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfcmpu (f0, f1) -> "Pfcmpu(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfcti (i0, f1) -> "Pfcti(" ^ string_of_ireg i0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfctiw (f0, f1) -> "Pfctiw(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfctiwz (f0, f1) -> "Pfctiwz(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfdiv (f0, f1, f2) -> "Pfdiv(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfdivs (f0, f1, f2) -> "Pfdivs(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfmake (f0, i1, i2) -> "Pfmake(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pfmr (f0, f1) -> "Pfmr(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfmul (f0, f1, f2) -> "Pfmul(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfmuls (f0, f1, f2) -> "Pfmuls(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfneg (f0, f1) -> "Pfneg(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfnegs (f0, f1) -> "Pfnegs(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfrsp (f0, f1) -> "Pfrsp(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfxdp (f0, f1) -> "Pfxdp(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfsub (f0, f1, f2) -> "Pfsub(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfsubs (f0, f1, f2) -> "Pfsubs(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ")" -| Pfmadd (f0, f1, f2, f3) -> "Pfmadd(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ", " ^ string_of_freg f3 ^ ")" -| Pfmsub (f0, f1, f2, f3) -> "Pfmsub(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ", " ^ string_of_freg f3 ^ ")" -| Pfnmadd (f0, f1, f2, f3) -> "Pfnmadd(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ", " ^ string_of_freg f3 ^ ")" -| Pfnmsub (f0, f1, f2, f3) -> "Pfnmsub(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ", " ^ string_of_freg f3 ^ ")" -| Pfsqrt (f0, f1) -> "Pfsqrt(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfrsqrte (f0, f1) -> "Pfrsqrte(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfres (f0, f1) -> "Pfres(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ")" -| Pfsel (f0, f1, f2, f3) -> "Pfsel(" ^ string_of_freg f0 ^ ", " ^ string_of_freg f1 ^ ", " ^ string_of_freg f2 ^ ", " ^ string_of_freg f3 ^ ")" -| Pisync -> "Pisync" -| Plbz (i0, c1, i2) -> "Plbz(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plbzx (i0, i1, i2) -> "Plbzx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfd (f0, c1, i2) -> "Plfd(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfd_a (f0, c1, i2) -> "Plfd_a(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfdx (f0, i1, i2) -> "Plfdx(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfdx_a (f0, i1, i2) -> "Plfdx_a(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfs (f0, c1, i2) -> "Plfs(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfsx (f0, i1, i2) -> "Plfsx(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plha (i0, c1, i2) -> "Plha(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plhax (i0, i1, i2) -> "Plhax(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plhbrx (i0, i1, i2) -> "Plhbrx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plhz (i0, c1, i2) -> "Plhz(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plhzx (i0, i1, i2) -> "Plhzx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plfi (f0, f1) -> "Plfi(" ^ string_of_freg f0 ^ ", " ^ string_of_ffloat f1 ^ ")" -| Plfis (f0, f1) -> "Plfis(" ^ string_of_freg f0 ^ ", " ^ string_of_ffloat32 f1 ^ ")" -| Plwarx (i0, i1, i2) -> "Plwarx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plwbrx (i0, i1, i2) -> "Plwbrx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plwz (i0, c1, i2) -> "Plwz(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plwzu (i0, c1, i2) -> "Plwzu(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plwz_a (i0, c1, i2) -> "Plwz_a(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plwzx (i0, i1, i2) -> "Plwzx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Plwzx_a (i0, i1, i2) -> "Plwzx_a(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pmfcr (i0) -> "Pmfcr(" ^ string_of_ireg i0 ^ ")" -| Pmfcrbit (i0, c1) -> "Pmfcrbit(" ^ string_of_ireg i0 ^ ", " ^ string_of_crbit c1 ^ ")" -| Pmflr (i0) -> "Pmflr(" ^ string_of_ireg i0 ^ ")" -| Pmr (i0, i1) -> "Pmr(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Pmtctr (i0) -> "Pmtctr(" ^ string_of_ireg i0 ^ ")" -| Pmtlr (i0) -> "Pmtlr(" ^ string_of_ireg i0 ^ ")" -| Pmulli (i0, i1, c2) -> "Pmulli(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Pmullw (i0, i1, i2) -> "Pmullw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pmulhw (i0, i1, i2) -> "Pmulhw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pmulhwu (i0, i1, i2) -> "Pmulhwu(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pnand (i0, i1, i2) -> "Pnand(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pnor (i0, i1, i2) -> "Pnor(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Por (i0, i1, i2) -> "Por(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Porc (i0, i1, i2) -> "Porc(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pori (i0, i1, c2) -> "Pori(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Poris (i0, i1, c2) -> "Poris(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Prlwinm (i0, i1, i2, i3) -> "Prlwinm(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_iint i2 ^ ", " ^ string_of_iint i3 ^ ")" -| Prlwimi (i0, i1, i2, i3) -> "Prlwimi(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_iint i2 ^ ", " ^ string_of_iint i3 ^ ")" -| Pslw (i0, i1, i2) -> "Pslw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psraw (i0, i1, i2) -> "Psraw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psrawi (i0, i1, i2) -> "Psrawi(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_iint i2 ^ ")" -| Psrw (i0, i1, i2) -> "Psrw(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstb (i0, c1, i2) -> "Pstb(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstbx (i0, i1, i2) -> "Pstbx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfd (f0, c1, i2) -> "Pstfd(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfd_a (f0, c1, i2) -> "Pstfd_a(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfdu (f0, c1, i2) -> "Pstfdu(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfdx (f0, i1, i2) -> "Pstfdx(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfdx_a (f0, i1, i2) -> "Pstfdx_a(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfs (f0, c1, i2) -> "Pstfs(" ^ string_of_freg f0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstfsx (f0, i1, i2) -> "Pstfsx(" ^ string_of_freg f0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psth (i0, c1, i2) -> "Psth(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psthx (i0, i1, i2) -> "Psthx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psthbrx (i0, i1, i2) -> "Psthbrx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstw (i0, c1, i2) -> "Pstw(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstw_a (i0, c1, i2) -> "Pstw_a(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstwu (i0, c1, i2) -> "Pstwu(" ^ string_of_ireg i0 ^ ", " ^ string_of_constant c1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstwx (i0, i1, i2) -> "Pstwx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstwx_a (i0, i1, i2) -> "Pstwx_a(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstwux (i0, i1, i2) -> "Pstwux(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstwbrx (i0, i1, i2) -> "Pstwbrx(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pstwcx_ (i0, i1, i2) -> "Pstwcx_(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psubfc (i0, i1, i2) -> "Psubfc(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psubfe (i0, i1, i2) -> "Psubfe(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Psubfze (i0, i1) -> "Psubfze(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ")" -| Psubfic (i0, i1, c2) -> "Psubfic(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Psync -> "Psync" -| Ptrap -> "Ptrap" -| Pxor (i0, i1, i2) -> "Pxor(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_ireg i2 ^ ")" -| Pxori (i0, i1, c2) -> "Pxori(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Pxoris (i0, i1, c2) -> "Pxoris(" ^ string_of_ireg i0 ^ ", " ^ string_of_ireg i1 ^ ", " ^ string_of_constant c2 ^ ")" -| Plabel (l0) -> "Plabel(" ^ string_of_label l0 ^ ")" -| Pbuiltin (e0, p1, p2) -> "Pbuiltin(" ^ string_of_external_function e0 ^ ", " ^ string_of_list string_of_preg ", " p1 ^ ", " ^ string_of_list string_of_preg ", " p2 ^ ")" -| Pannot (e0, a1) -> - let sp_reg_name = string_of_external_function e0 in - "Pannot(" ^ string_of_external_function e0 ^ ", " ^ string_of_list (string_of_annot_param sp_reg_name) ", " a1 ^ ")" -| Pcfi_adjust n -> "Pcfi_adjust(" ^ string_of_coq_Z n ^ ")" -| Pcfi_rel_offset n -> "Pcfi_rel_offset(" ^ string_of_coq_Z n ^ ")" - -let string_of_init_data = function -| Init_int8(i) -> "Init_int8(" ^ string_of_int (z_int_lax i) ^ ")" -| Init_int16(i) -> "Init_int16(" ^ string_of_int (z_int_lax i) ^ ")" -| Init_int32(i) -> "Init_int32(" ^ string_of_int32i (z_int32 i) ^ ")" -| Init_int64(i) -> "Init_int64(" ^ string_of_int64i (z_int64 i) ^ ")" -| Init_float32(f) -> "Init_float32(" ^ string_of_ffloat32 f ^ ")" -| Init_float64(f) -> "Init_float64(" ^ string_of_ffloat f ^ ")" -| Init_space(z) -> "Init_space(" ^ string_of_int (z_int z) ^ ")" -| Init_addrof(ident, ofs) -> - "Init_addrof(" ^ string_of_pos ident ^ ", " ^ string_of_int32i (z_int32 ofs) ^ ")" diff --git a/checklink/Bitstring_utils.ml b/checklink/Bitstring_utils.ml deleted file mode 100644 index 3218f898..00000000 --- a/checklink/Bitstring_utils.ml +++ /dev/null @@ -1,33 +0,0 @@ -(** Note that a bitstring is a triple (string * int * int), where the string - contains the contents (the last char is filled up with zeros if necessary), - the firts int gives the first bit to consider, and the second int gives the - bit length of the considered bitstring. -*) -type bitstring = Bitstring.bitstring - -(** Checks whether a given number of bits of a bitstring are zeroed. The - bitstring may be longer. - @param size number of bits to check -*) - -let is_zeros (bs: bitstring) (size: int): bool = - Bitstring.bitstring_length bs >= size - && Bitstring.is_zeroes_bitstring (Bitstring.subbitstring bs 0 size) - -(* - -let rec is_zeros (bs: bitstring) (size: int): bool = - size = 0 || - if size >= 64 - then ( - bitmatch bs with - | { 0L : 64 : int ; rest : -1 : bitstring } -> - is_zeros rest (size - 64) - | { _ } -> false - ) - else ( - bitmatch bs with - | { 0L : size : int } -> true - | { _ } -> false - ) -*) diff --git a/checklink/Check.ml b/checklink/Check.ml deleted file mode 100644 index b2b9077c..00000000 --- a/checklink/Check.ml +++ /dev/null @@ -1,3216 +0,0 @@ -open Asm -open Asm_printers -open AST -open Bitstring_utils -open C2C -open Camlcoq -open ELF_parsers -open ELF_printers -open ELF_types -open ELF_utils -open Frameworks -open Lens -open Library -open PPC_parsers -open PPC_printers -open PPC_types -open PPC_utils -open Sections - -(** Enables immediate printing of log information to stdout. - Warning: will print out everything even when backtracking. -*) -let debug = ref false - -(** Whether to print the ELF map. *) -let print_elfmap = ref false - -(** Whether to dump the ELF map. *) -let dump_elfmap = ref false - -(** Whether to check that all ELF function/data symbols have been matched - against CompCert idents. *) -let exhaustivity = ref true - -(** Whether to print the list of all symbols (function and data) that were not - found in .sdump files. *) -let list_missing = ref false - -(** CompCert Asm *) -type ccode = Asm.coq_function - -let print_debug s = - if !debug then print_endline (string_of_log_entry true (DEBUG(s))) - -(** Adds a log entry into the framework. *) -let add_log (entry: log_entry) (efw: e_framework): e_framework = - if !debug then print_endline ("--DEBUG-- " ^ string_of_log_entry true entry); - {efw with log = entry :: efw.log} - -(** [flag] should have only one bit set. *) -let is_set_flag (flag: int32) (bitset: int32): bool = - Int32.logand bitset flag <> 0l - -(** Checks that [atom]'s binding matches [sym]'s. *) -let check_st_bind atom (sym: elf32_sym): s_framework -> s_framework = - let static = atom.a_storage = C.Storage_static || atom.a_inline in - match static, sym.st_bind with - | true, STB_LOCAL -> id - | false, STB_GLOBAL -> id - | _ -> ( - sf_ef ^%= - add_log (ERROR( - "Symbol: " ^ sym.st_name ^ " has a wrong binding (local vs. global)" - )) - ) - -(** Adapted from CompCert *) -let name_of_section_Linux: section_name -> string = function -| Section_text -> ".text" -| Section_data i -> if i then ".data" else "COMM" -| Section_small_data i -> if i then ".sdata" else ".sbss" -| Section_const i -> if i then ".rodata" else "COMM" -| Section_small_const i -> if i then ".sdata2" else "COMM" -| Section_string -> ".rodata" -| Section_literal -> ".rodata.cst8" -| Section_jumptable -> ".text" -| Section_user(s, wr, ex) -> s -| Section_debug_info -> ".debug_info" -| Section_debug_abbrev -> ".debug_abbrev" - -(** Adapted from CompCert *) -let name_of_section_Diab: section_name -> string = function -| Section_text -> ".text" -| Section_data i -> if i then ".data" else "COMM" -| Section_small_data i -> if i then ".sdata" else ".sbss" -| Section_const _ -> ".text" -| Section_small_const _ -> ".sdata2" -| Section_string -> ".text" -| Section_literal -> ".text" -| Section_jumptable -> ".text" -| Section_user(s, wr, ex) -> s -| Section_debug_info -> ".debug_info" -| Section_debug_abbrev -> ".debug_abbrev" - -(** Taken from CompCert *) -let name_of_section: section_name -> string = - begin match Configuration.system with - | "linux" -> name_of_section_Linux - | "diab" -> name_of_section_Diab - | _ -> fatal "Unsupported CompCert configuration" - end - -(** Compares a CompCert section name with an ELF section name. *) -let match_sections_name - (c_section: section_name) (e_name: string) (sfw: s_framework): - s_framework - = - let c_name = name_of_section c_section in - try - let (value, conflicts) = StringMap.find c_name sfw.ef.section_map in - let expected = from_inferrable value in - if e_name = expected - then sfw - else ( - sfw - >>> (sf_ef |-- section_map) ^%= - StringMap.add c_name (value, StringSet.add e_name conflicts) - ) - with Not_found -> ( - sfw - >>> (sf_ef |-- section_map) ^%= - StringMap.add c_name (Inferred(e_name), StringSet.empty) - ) - -(** Checks the symbol table entry of the function symbol number [sym_ndx], - according to CompCert's [ident]. -*) -let check_fun_symtab - (ident: ident) (sym_ndx: int) (sfw: s_framework): - s_framework - = - let elf = sfw.ef.elf in - let symtab_sndx = from_some (section_ndx_by_name elf ".symtab") in - let symtab_ent_start = - Int32.(add - elf.e_shdra.(symtab_sndx).sh_offset - (Safe32.of_int (16 * sym_ndx))) in - let sym = sfw.ef.elf.e_symtab.(sym_ndx) in - let atom = Hashtbl.find sfw.atoms ident in - let section = - match atom.a_sections with - | [t; _; _] -> t - | _ -> Section_text - in - sfw - >>> check_st_bind atom sym - >>> ( - if sym.st_type = STT_FUNC - then id - else (sf_ef ^%= - add_log (ERROR("Symbol should have type STT_FUNC")) - ) - ) - >>> ( - if sym.st_other = 0 - then id - else (sf_ef ^%= - add_log (ERROR("Symbol should have st_other set to 0")) - ) - ) - >>> match_sections_name section elf.e_shdra.(sym.st_shndx).sh_name - >>> sf_ef ^%= - add_range symtab_ent_start 16l 4 (Symtab_function(sym)) - -(** Checks that the offset [ofs] is well aligned with regards to [al], expressed - in bytes. *) -let is_well_aligned (ofs: int32) (al: int): bool = - al = 0 || Int32.rem ofs (Safe32.of_int al) = 0l - -(** Adds a function symbol to the set of covered symbols. *) -let mark_covered_fun_sym_ndx (ndx: int) ffw: f_framework = - let elf = ffw.sf.ef.elf in - let sym = elf.e_symtab.(ndx) in - let sym_sndx = sym.st_shndx in - let sym_size = sym.st_size in - let sym_shdr = elf.e_shdra.(sym_sndx) in - let sym_vaddr = sym.st_value in - let sym_ofs_local = Int32.sub sym_vaddr sym_shdr.sh_addr in - let sxn_ofs = sym_shdr.sh_offset in - let sym_begin = Int32.add sxn_ofs sym_ofs_local in - let atom = Hashtbl.find ffw.sf.atoms ffw.this_ident in - let align = - match atom.a_alignment with - | Some(a) -> a - | None -> 0 - in - ffw.sf.ef.chkd_fun_syms.(ndx) <- true; - ffw - >>> (ff_ef ^%= add_range sym_begin sym_size align (Function_symbol(sym))) - >>> (ff_sf ^%= - if not (is_well_aligned sym_ofs_local align) - then ( - sf_ef ^%= - add_log (ERROR("Symbol not correctly aligned in the ELF file")) - ) - else id - ) - >>> (ff_sf ^%= check_fun_symtab ffw.this_ident ndx) - -(** Tries to refine the mapping for key [k] in [ident_to_sym_ndx] so that it is - mapped to [vaddr]. Fails if no symbol in [k]'s mapping has that virtual - address. Otherwise, it filters out all symbols whose virtual - address does not match [vaddr]. -*) -let idmap_unify (k: P.t) (vaddr: int32) (sfw: s_framework) - : s_framework or_err = - try ( - (* get the list of possible symbols for ident [k] *) - let id_ndxes = PosMap.find k sfw.ident_to_sym_ndx in - (* consider only the ones at the correct virtual address *) - match List.filter - (fun ndx -> sfw.ef.elf.e_symtab.(ndx).st_value = vaddr) - id_ndxes - with - | [] -> - (* no symbol has that virtual address *) - ERR( - Printf.sprintf - "Incoherent constraints for ident %s with value %s and candidates [%s]" - (Hashtbl.find sfw.ident_to_name k) - (string_of_int32 vaddr) - (string_of_list - (fun ndx -> string_of_int32 sfw.ef.elf.e_symtab.(ndx).st_value) - ", " id_ndxes - ) - ) - | ndxes -> - if id_ndxes = ndxes - then OK(sfw) - else OK((ident_to_sym_ndx ^%= (PosMap.add k ndxes)) sfw) - ) - with - | Not_found -> - ERR( - Printf.sprintf - "Missing ident: %s should be at vaddr: %s" - (Hashtbl.find sfw.ident_to_name k) - (string_of_int32 vaddr) - ) - -(** Checks whether the label [k] points to [v] in [label_to_vaddr]. If it points - to another virtual address, this returns an ERR. If it points to nothing, - the mapping [k] -> [v] is added. Thus, the first time a label is - encountered determines the expected virtual address of its destination. - Subsequent references to the label will have to conform. -*) -let lblmap_unify (k: label) (v: int32) (ffw: f_framework) - : f_framework or_err = - try ( - let v' = PosMap.find k ffw.label_to_vaddr in - if v = v' - then OK ffw - else ( - ERR( - "Incoherent constraints for label " ^ - string_of_positive k ^ " with values " ^ - string_of_int32 v ^ " and " ^ string_of_int32 v' - ) - ) - ) - with - | Not_found -> - OK { - ffw with - label_to_vaddr = PosMap.add k v ffw.label_to_vaddr - } - -let ireg_arr: ireg array = - [| - GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7; GPR8; GPR9; GPR10; GPR11; - GPR12; GPR13; GPR14; GPR15; GPR16; GPR17; GPR18; GPR19; GPR20; GPR21; GPR22; - GPR23; GPR24; GPR25; GPR26; GPR27; GPR28; GPR29; GPR30; GPR31 - |] - -let freg_arr: freg array = - [| - FPR0; FPR1; FPR2; FPR3; FPR4; FPR5; FPR6; FPR7; FPR8; FPR9; FPR10; FPR11; - FPR12; FPR13; FPR14; FPR15; FPR16; FPR17; FPR18; FPR19; FPR20; FPR21; FPR22; - FPR23; FPR24; FPR25; FPR26; FPR27; FPR28; FPR29; FPR30; FPR31 - |] - -let num_crbit = function - | CRbit_0 -> 0 - | CRbit_1 -> 1 - | CRbit_2 -> 2 - | CRbit_3 -> 3 - | CRbit_6 -> 6 - -type checker = f_framework -> f_framework or_err -let check (cond: bool) (msg: string): checker = - fun ffw -> if cond then OK(ffw) else ERR(msg) -let check_eq (msg: string) (a: 'a) (b: 'a): checker = - check (a = b) msg -let match_bools a b = - check_eq ( - Printf.sprintf "match_bools %s %s" (string_of_bool a) (string_of_bool b) - ) a b -let match_ints a b = - check_eq ( - Printf.sprintf "match_ints %s %s" (string_of_int a) (string_of_int b) - ) a b -let match_int32s a b: checker = - check_eq ( - Printf.sprintf "match_int32s %s %s" (string_of_int32 a) (string_of_int32 b) - ) a b -(** We compare floats by their bit representation, so that 0.0 and -0.0 are - different. *) -let match_floats (a: Floats.float) (b: int64): checker = - let a = camlint64_of_coqint (Floats.Float.to_bits a) in - check_eq ( - Printf.sprintf "match_floats %s %s" (string_of_int64 a) (string_of_int64 b) - ) a b -let match_floats32 (a: Floats.float32) (b: int32): checker = - let a = camlint_of_coqint (Floats.Float32.to_bits a) in - check_eq ( - Printf.sprintf "match_floats %s %s" (string_of_int32 a) (string_of_int32 b) - ) a b -let match_crbits cb eb = - let cb = num_crbit cb in - check_eq ( - Printf.sprintf "match_crbits %d %d" cb eb - ) cb eb -let match_iregs cr er = - let er = ireg_arr.(er) in - check_eq ( - Printf.sprintf "match_iregs %s %s" (string_of_ireg cr) (string_of_ireg er) - ) cr er -let match_fregs cr er = - let er = freg_arr.(er) in - check_eq ( - Printf.sprintf "match_fregs %s %s" (string_of_freg cr) (string_of_freg er) - ) cr er - -let name_of_ndx (efw: e_framework) (ndx: int): string = - let st = efw.elf.e_symtab.(ndx) in - st.st_name ^ " at address " ^ (string_of_int32 st.st_value) - -(** Filters the lower 16 bits of an int32. *) -let low: int32 -> int32 = Int32.logand 0x0000ffffl - -(** high_exts x is equal to: - - - the 16 high bits of x if its lower 16 bits form a positive 16 bit integer - - - the 16 high bits of x plus one otherwise - - This is so that: x == high_exts x + exts (low x) -*) -let high_exts (x: int32): int32 = Int32.( - if logand x 0x00008000l = 0l - then logand x 0xffff0000l - else add 0x00010000l (logand x 0xffff0000l) -) - -(** Matches a CompCert constant against an [int32]. *) -let match_csts (cc: constant) (ec: int32): checker = fun ffw -> - let sfw = ffw |. ff_sf in - let efw = ffw |. ff_ef in - match cc with - | Cint (i) -> - let i = z_int32_lax i in - let msg = - Printf.sprintf "match_csts Cint %s %s" - (string_of_int32 i) - (string_of_int32 ec) - in - check_eq msg ec i ffw - | Csymbol_low (ident, i) -> - let candidates = - try PosMap.find ident sfw.ident_to_sym_ndx - with Not_found -> [] - in - let vaddrs = - List.filter - (fun ndx -> - let ident_vaddr = efw.elf.e_symtab.(ndx).st_value in - Int32.(low (add ident_vaddr (z_int32_lax i)) = low ec) - ) - candidates - in - begin match vaddrs with - | [] -> - let sym_names = List.map (name_of_ndx efw) candidates in - ERR("Csymbol_low " ^ string_of_list id ", " sym_names) - | _ -> - if candidates = vaddrs - then OK(ffw) - else OK( - ffw - >>> ((ff_sf |-- ident_to_sym_ndx) ^%= (PosMap.add ident vaddrs)) - ) - end - | Csymbol_high (ident, i) -> - (* In this case, ec is 0x0000XXXX standing for XXXX0000 *) - let candidates = - try PosMap.find ident sfw.ident_to_sym_ndx - with Not_found -> [] - in - let vaddrs = - List.filter - (fun ndx -> - let ident_vaddr = efw.elf.e_symtab.(ndx).st_value in - Int32.(high_exts (add ident_vaddr (z_int32_lax i)) - = shift_left ec 16)) - candidates in - begin match vaddrs with - | [] -> - let sym_names = List.map (name_of_ndx efw) candidates in - ERR("Csymbol_high " ^ string_of_list id ", " sym_names) - | _ -> - if candidates = vaddrs - then OK(ffw) - else OK( - ffw - >>> ((ff_sf |-- ident_to_sym_ndx) ^%= (PosMap.add ident vaddrs)) - ) - end - | Csymbol_sda (ident, i) -> - (* sda should be handled separately in places it occurs *) - ERR("Incorrect reference to near-data symbol " - ^ Hashtbl.find ffw.sf.ident_to_name ident) - | Csymbol_rel_low (ident, i) | Csymbol_rel_high (ident, i) -> - (* should be handled separately in places it occurs *) - ERR("Incorrect reference to far-data symbol " - ^ Hashtbl.find ffw.sf.ident_to_name ident) - -let match_z_int32 (cz: Z.t) (ei: int32) = - let cz = z_int32 cz in - check_eq ( - Printf.sprintf "match_z_int32 %s %s" (string_of_int32 cz) (string_of_int32 ei) - ) cz ei - -let match_z_int (cz: Z.t) (ei: int) = - let cz = z_int32 cz in - let ei = Safe32.of_int ei in - check_eq ( - Printf.sprintf "match_z_int %s %s" (string_of_int32i cz) (string_of_int32i ei) - ) cz ei - -(* [m] is interpreted as a bitmask, and checked against [ei]. *) -let match_mask (m: Z.t) (ei: int32) = - let m = z_int32_lax m in - check_eq ( - Printf.sprintf "match_mask %s %s" - (string_of_int32 m) - (string_of_int32 ei) - ) m ei - -(** Checks that the special register referred to in [spr] is [r]. *) -let match_spr (str: string) (r: int) (spr: bitstring): checker = fun ffw -> - bitmatch spr with - | { v:5; 0:5 } when v = r -> OK(ffw) - | { _ } -> ERR(str) - -let match_xer = match_spr "match_xer" 1 -let match_lr = match_spr "match_lr" 8 -let match_ctr = match_spr "match_ctr" 9 - -(** Read a n-bits bitstring as a signed integer, two's complement representation - (n < 32). -*) -let exts (bs: bitstring): int32 = - let signif_bits = Bitstring.bitstring_length bs - 1 in - bitmatch bs with - | { sign : 1 ; - rest : signif_bits : int } -> - Int64.( - to_int32 ( - if sign - then logor rest (lognot (sub (shift_left one signif_bits) one)) - else rest - ) - ) - -(** Creates a bitmask from bits mb to me, according to the specification in - "4.2.1.4 Integer Rotate and Shift Instructions" of the PowerPC manual. -*) -let rec bitmask mb me = - assert (0 <= mb); assert (0 <= me); assert (mb < 32); assert (me < 32); - if (mb, me) = (0, 31) - then -1l (* this case does not compute correctly otherwise *) - else if mb <= me - (* 0 ... mb ... me ... 31 - 0 0 0 1 1 1 1 1 0 0 0 - *) - then Int32.(shift_left - (sub (shift_left 1l (me - mb + 1)) 1l) - (31 - me) - ) - (* - 0 ... me ... mb ... 31 - 1 1 1 1 0 0 0 1 1 1 1 - == - 1 1 1 1 1 1 1 1 1 1 1 -1l - - - 0 0 0 0 1 1 1 0 0 0 0 bitmask (me + 1) (mb - 1) - *) - else if mb = me + 1 - then (-1l) (* this needs special handling *) - else Int32.(sub (-1l) (bitmask (me + 1) (mb - 1))) - -(** Checks that a label did not occur twice in the same function. *) -let check_label_unicity ffw = - let rec check_label_unicity_aux l ffw = - match l with - | [] -> ffw - | h::t -> - ffw - >>> ( - if List.mem h t - then ( - ff_ef ^%= - (add_log (ERROR("Duplicate label: " ^ string_of_positive h))) - ) - else id - ) - >>> check_label_unicity_aux t - in - check_label_unicity_aux ffw.label_list ffw - -(** Checks that all the labels that have been referred to in instructions - actually appear in the code. *) -let check_label_existence ffw = - PosMap.fold - (fun k v -> - if List.mem k ffw.label_list - then id - else ( - ff_ef ^%= - (add_log (ERROR("Missing label: " ^ string_of_positive k))) - ) - ) - ffw.label_to_vaddr - ffw - -(** Matches the segment at virtual address [vaddr] with the jumptable expected - from label list [lbllist]. Then checks whether the matched chunk of the code - had the expected [size]. -*) -let rec match_jmptbl lbllist vaddr size ffw = - let rec match_jmptbl_aux lbllist bs ffw = - match lbllist with - | [] -> OK ffw - | lbl :: lbls -> ( - bitmatch bs with - | { vaddr : 32 : int; - rest : -1 : bitstring } -> - ffw - >>> lblmap_unify lbl vaddr - >>= match_jmptbl_aux lbls rest - | { _ } -> - ERR("Ill-formed jump table") - ) - in - let elf = ffw.sf.ef.elf in - begin match bitstring_at_vaddr elf vaddr size with - | None -> ERR("No section for the jumptable") - | Some(bs, pofs, psize) -> - ffw - >>> match_jmptbl_aux lbllist bs - >>^ (ff_ef ^%= - add_range pofs psize 0 Jumptable - ) - end - -let match_bo_bt_bool bo = - bitmatch bo with - | { false:1; true:1; true:1; false:1; false:1 } -> true - | { _ } -> false - -let match_bo_bf_bool bo = - bitmatch bo with - | { false:1; false:1; true:1; false:1; false:1 } -> true - | { _ } -> false - -let match_bo_bdnz_bool bo = - bitmatch bo with - | { true:1; false:1; false:1; false:1; false:1 } -> true - | { _ } -> false - -let match_bo_bt bo: checker = fun ffw -> - bitmatch bo with - | { false:1; true:1; true:1; false:1; false:1 } -> OK(ffw) - | { _ } -> ERR("match_bo_bt") - -let match_bo_bf bo: checker = fun ffw -> - if match_bo_bf_bool bo - then OK(ffw) - else ERR("match_bo_bf") - -let match_bo_ctr bo: checker = fun ffw -> - bitmatch bo with - | { true:1; false:1; true:1; false:1; false:1 } -> OK(ffw) - | { _ } -> ERR("match_bo_ctr") - -(** Checks whether it is feasible that the position at offset [ofs] from the - CompCert symbol [ident] is situated at a relative address [addr] from - the SDA register [r]. This means that the following equation must hold: - [r] + addr = @ident + ofs - This allows us to determine what address [r] has to contain. If it is the - first such guess or if it matches previous expectations, it's fine. - Otherwise, there is a conflict that is reported in sda_map. -*) -let check_sda ident ofs r addr ffw: f_framework or_err = - let ofs = z_int32 ofs in - let check_sda_aux ndx: (int * f_framework) or_err = - let elf = ffw.sf.ef.elf in - let sym = elf.e_symtab.(ndx) in - let expected_addr = Safe32.(sym.st_value + ofs - addr) in - try - let r_addr = from_inferrable (IntMap.find r ffw.sf.ef.sda_map) in - if r_addr = expected_addr - then OK(ndx, ffw) - else ERR( - Printf.sprintf - "SDA register %d is expected to point both at 0x%lx and 0x%lx" - r r_addr expected_addr - ) - with Not_found -> - OK(ndx, - ffw >>> (ff_ef |-- sda_map) ^%= IntMap.add r (Inferred(expected_addr)) - ) - in - (* We might not know yet what symbols is the one for that ident *) - let sym_list = PosMap.find ident ffw.sf.ident_to_sym_ndx in - (* So we test all the candidates *) - let res = List.map check_sda_aux sym_list in - (* For now, we hope at most one matches *) - match filter_ok res with - | [] -> ERR("No satisfying SDA mapping, errors were: " ^ - string_of_list id ", " (filter_err res)) - | [(ndx, ffw)] -> OK( - ffw - (* We instantiate the relationship for that ident to the matching symbol *) - >>> (ff_sf |-- ident_to_sym_ndx) ^%= PosMap.add ident [ndx] - ) - | _ -> fatal "Multiple possible SDA mappings, please report." - -(** Compares a whole CompCert function code against an ELF code, starting at - program counter [pc]. -*) -let rec compare_code ccode ecode pc: checker = fun fw -> - match ccode, ecode with - | [], [] -> OK(fw) - | [], e_rest -> - let rest_str = String.concat "\n" (List.map string_of_instr e_rest) in - ERR("CompCert code exhausted before the end of ELF code, remaining:\n" - ^ rest_str) - | c_rest, [] -> - let rest_str = String.concat "\n" (List.map string_of_instruction c_rest) in - ERR("ELF code exhausted before the end of CompCert code, remaining:\n" - ^ rest_str) - | c::cs, e::es -> - let recur_simpl = compare_code cs es (Int32.add 4l pc) in - let current_instr = - "[" ^ string_of_int32 pc ^ "] " ^ string_of_instruction c ^ " - " ^ string_of_instr e in - let error = ERR("Non-matching instructions: " ^ current_instr) in - let fw = - if !debug - then (ff_ef ^%= add_log (DEBUG(current_instr))) fw - else fw - in - match c with - | Padd(rd, r1, r2) -> - begin match ecode with - | ADDx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Paddc(rd, r1, r2) -> - begin match ecode with - | ADDCx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Padde(rd, r1, r2) -> - begin match ecode with - | ADDEx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Paddi(rd, r1, Csymbol_sda(ident, ofs)) -> - begin match ecode with - | ADDI(rD, rA, simm) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= check_sda ident ofs rA (exts simm) - >>= recur_simpl - | _ -> error - end - | Paddi(rd, r1, cst) -> - begin match ecode with - | ADDI(rD, rA, simm) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (exts simm) - >>= recur_simpl - | _ -> error - end - | Paddic(rd, r1, cst) -> - begin match ecode with - | ADDIC(rD, rA, simm) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (exts simm) - >>= recur_simpl - | _ -> error - end - | Paddis(rd, r1, Csymbol_rel_high(id, ofs)) -> - begin match cs with - | Paddi(rd', r1', Csymbol_rel_low(id', ofs')) :: cs - when id' = id && ofs' = ofs -> - begin match ecode with - | ADDIS(rD, rA, simm) :: ADDI(rD', rA', simm') :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1' rA' - >>= match_iregs rd' rD' - >>= check_sda id ofs rA - Int32.(add (shift_left (of_int simm) 16) (exts simm')) - >>= compare_code cs es (Int32.add 8l pc) - | _ -> error - end - | _ -> error - end - | Paddis(rd, r1, cst) -> - begin match ecode with - | ADDIS(rD, rA, simm) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (Safe32.of_int simm) - >>= recur_simpl - | _ -> error - end - | Paddze(rd, r1) -> - begin match ecode with - | ADDZEx(rD, rA, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pallocframe(sz, ofs) -> error - | Pandc(rd, r1, r2) -> - begin match ecode with - | ANDCx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pand_(rd, r1, r2) -> - begin match ecode with - | ANDx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools true rc - >>= recur_simpl - | _ -> error - end - | Pandis_(rd, r1, cst) -> - begin match ecode with - | ANDIS_(rS, rA, uimm) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_csts cst (Safe32.of_int uimm) - >>= recur_simpl - | _ -> error - end - | Pandi_(rd, r1, cst) -> - begin match ecode with - | ANDI_(rS, rA, uimm) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_csts cst (Safe32.of_int uimm) - >>= recur_simpl - | _ -> error - end - | Pannot(ef, args) -> - OK(fw) - >>= compare_code cs ecode pc - | Pb(lbl) -> - begin match ecode with - | Bx(li, aa, lk) :: es -> - let lblvaddr = Int32.(add pc (mul 4l (exts li))) in - OK(fw) - >>= lblmap_unify lbl lblvaddr - >>= match_bools false aa - >>= match_bools false lk - >>= recur_simpl - | _ -> error - end - | Pbctr sg -> - begin match ecode with - | BCCTRx(bo, bi, lk) :: es -> - OK(fw) - >>= match_bo_ctr bo - >>= match_ints 0 bi - >>= match_bools false lk - >>= recur_simpl - | _ -> error - end - | Pbctrl sg -> - begin match ecode with - | BCCTRx(bo, bi, lk) :: es -> - OK(fw) - >>= match_bo_ctr bo - >>= match_ints 0 bi - >>= match_bools true lk - >>= recur_simpl - | _ -> error - end - | Pbdnz(lbl) -> - begin match ecode with - | BCx (bo, bi, bd, aa, lk) :: es when match_bo_bdnz_bool bo -> - let lblvaddr = Int32.(add pc (mul 4l (exts bd))) in - OK(fw) - >>= match_ints 0 bi - >>= lblmap_unify lbl lblvaddr - >>= match_bools false aa - >>= match_bools false lk - >>= recur_simpl - | _ -> error - end - | Pbf(bit, lbl) -> - begin match ecode with - | BCx(bo, bi, bd, aa, lk) :: es when match_bo_bf_bool bo -> - let lblvaddr = Int32.(add pc (mul 4l (exts bd))) in - OK(fw) - (*>>= match_bo_bf bo already done in pattern match *) - >>= match_crbits bit bi - >>= lblmap_unify lbl lblvaddr - >>= match_bools false aa - >>= match_bools false lk - >>= recur_simpl - | BCx(bo0, bi0, bd0, aa0, lk0) :: - Bx (li1, aa1, lk1) :: es -> - let cnext = Int32.add pc 8l in - let enext = Int32.(add pc (mul 4l (exts bd0))) in - let lblvaddr = Int32.(add pc (mul 4l (exts bd0))) in - OK(fw) - >>= match_bo_bt bo0 - >>= match_crbits bit bi0 - >>= match_int32s cnext enext - >>= match_bools false aa0 - >>= match_bools false lk0 - >>= lblmap_unify lbl lblvaddr - >>= match_bools false aa1 - >>= match_bools false lk1 - >>= compare_code cs es (Int32.add 8l pc) - | _ -> error - end - | Pbl(ident, sg) -> - begin match ecode with - | Bx(li, aa, lk) :: es -> - let dest = Int32.(add pc (mul 4l (exts li))) in - OK(fw) - >>= (ff_sf ^%=? idmap_unify ident dest) - >>= match_bools false aa - >>= match_bools true lk - >>= recur_simpl - | _ -> error - end - | Pblr -> - begin match ecode with - | BCLRx(bo, bi, lk) :: es -> - OK(fw) - >>= match_bo_ctr bo - >>= match_ints 0 bi - >>= match_bools false lk - >>= recur_simpl - | _ -> error - end - | Pbs(ident, sg) -> - begin match ecode with - | Bx(li, aa, lk) :: es -> - let dest = Int32.(add pc (mul 4l (exts li))) in - OK(fw) - >>= match_bools false aa - >>= match_bools false lk - >>= (ff_sf ^%=? idmap_unify ident dest) - >>= recur_simpl - | _ -> error - end - | Pbt(bit, lbl) -> - begin match ecode with - | BCx(bo, bi, bd, aa, lk) :: es when match_bo_bt_bool bo -> - let lblvaddr = Int32.(add pc (mul 4l (exts bd))) in - OK(fw) - (*>>= match_bo_bt bo already done in pattern match *) - >>= match_crbits bit bi - >>= lblmap_unify lbl lblvaddr - >>= match_bools false aa - >>= match_bools false lk - >>= recur_simpl - | BCx(bo0, bi0, bd0, aa0, lk0) :: - Bx (li1, aa1, lk1) :: es -> - let cnext = Int32.add pc 8l in - let enext = Int32.(add pc (mul 4l (exts bd0))) in - let lblvaddr = Int32.(add pc (mul 4l (exts bd0))) in - OK(fw) - >>= match_bo_bf bo0 - >>= match_crbits bit bi0 - >>= match_int32s cnext enext - >>= match_bools false aa0 - >>= match_bools false lk0 - >>= lblmap_unify lbl lblvaddr - >>= match_bools false aa1 - >>= match_bools false lk1 - >>= compare_code cs es (Int32.add 8l pc) - | _ -> error - end - | Pbtbl(reg, table) -> - begin match ecode with - | RLWINMx(rS0, rA0, sh, mb, me, rc0) :: - ADDIS (rD1, rA1, simm1) :: - LWZ (rD2, rA2, d2) :: - MTSPR (rS3, spr3) :: - BCCTRx(bo4, bi4, rc4) :: es -> - let tblvaddr = Int32.( - add (shift_left (Safe32.of_int simm1) 16) (exts d2) - ) in - let tblsize = Safe32.of_int (4 * List.length table) in - OK(fw) - >>= match_iregs GPR12 rA0 - >>= match_iregs reg rS0 - >>= match_ints sh 2 - >>= match_ints mb 0 - >>= match_ints me 29 - >>= match_bools false rc0 - >>= match_iregs GPR12 rA1 - >>= match_iregs GPR12 rD1 - >>= match_iregs GPR12 rA2 - >>= match_iregs GPR12 rD2 - >>= match_iregs GPR12 rS3 - >>= match_ctr spr3 - >>= match_bo_ctr bo4 - >>= match_ints 0 bi4 - >>= match_bools false rc4 - >>= match_jmptbl table tblvaddr tblsize - >>= compare_code cs es (Int32.add 20l pc) - | _ -> error - end - | Pbuiltin(ef, args, res) -> - begin match ef with - | EF_inline_asm(_) -> fatal "Unsupported: inline asm statement." - | _ -> fatal "Unexpected Pbuiltin, please report." - end - | Pcfi_adjust _ | Pcfi_rel_offset _ -> - OK(fw) - >>= compare_code cs ecode pc - | Pcmplw(r1, r2) -> - begin match ecode with - | CMPL(crfD, l, rA, rB) :: es -> - OK(fw) - >>= match_crbits CRbit_0 crfD - >>= match_bools false l - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pcmplwi(r1, cst) -> - begin match ecode with - | CMPLI(crfD, l, rA, uimm) :: es -> - OK(fw) - >>= match_iregs r1 rA - >>= match_csts cst (Safe32.of_int uimm) - >>= match_crbits CRbit_0 crfD - >>= match_bools false l - >>= recur_simpl - | _ -> error - end - | Pcmpw(r1, r2) -> - begin match ecode with - | CMP(crfD, l, rA, rB) :: es -> - OK(fw) - >>= match_ints crfD 0 - >>= match_bools l false - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pcmpwi(r1, cst) -> - begin match ecode with - | CMPI(crfD, l, rA, simm) :: es -> - OK(fw) - >>= match_ints crfD 0 - >>= match_bools false l - >>= match_iregs r1 rA - >>= match_csts cst (exts simm) - >>= recur_simpl - | _ -> error - end - | Pcntlzw(r1, r2) -> - begin match ecode with - | CNTLZWx(rS, rA, rc) :: es -> - OK(fw) - >>= match_iregs r2 rS - >>= match_iregs r1 rA - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pcreqv(bd, b1, b2) -> - begin match ecode with - | CREQV(crbD, crbA, crbB) :: es -> - OK(fw) - >>= match_crbits bd crbD - >>= match_crbits b1 crbA - >>= match_crbits b2 crbB - >>= recur_simpl - | _ -> error - end - | Pcror(bd, b1, b2) -> - begin match ecode with - | CROR(crbD, crbA, crbB) :: es -> - OK(fw) - >>= match_crbits bd crbD - >>= match_crbits b1 crbA - >>= match_crbits b2 crbB - >>= recur_simpl - | _ -> error - end - | Pcrxor(bd, b1, b2) -> - begin match ecode with - | CRXOR(crbD, crbA, crbB) :: es -> - OK(fw) - >>= match_crbits bd crbD - >>= match_crbits b1 crbA - >>= match_crbits b2 crbB - >>= recur_simpl - | _ -> error - end - | Pdivw(rd, r1, r2) -> - begin match ecode with - | DIVWx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pdivwu(rd, r1, r2) -> - begin match ecode with - | DIVWUx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Peieio -> - begin match ecode with - | EIEIO :: es -> - OK(fw) - >>= recur_simpl - | _ -> error - end - | Peqv(rd, r1, r2) -> - begin match ecode with - | EQVx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pextsb(rd, r1) -> - begin match ecode with - | EXTSBx(rS, rA, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pextsh(rd, r1) -> - begin match ecode with - | EXTSHx(rS, rA, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfabs(rd, r1) | Pfabss(rd, r1) -> - begin match ecode with - | FABSx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfadd(rd, r1, r2) -> - begin match ecode with - | FADDx(frD, frA, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfadds(rd, r1, r2) -> - begin match ecode with - | FADDSx(frD, frA, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfcmpu(r1, r2) -> - begin match ecode with - | FCMPU(crfD, frA, frB) :: es -> - OK(fw) - >>= match_crbits CRbit_0 crfD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= recur_simpl - | _ -> error - end - | Pfcti(rd, r1) -> - error - | Pfctiw(rd, r1) -> - begin match ecode with - | FCTIWx(frD0, frB0, rc0) :: es -> - OK(fw) - >>= match_fregs rd frD0 - >>= match_fregs r1 frB0 - >>= match_bools false rc0 - >>= recur_simpl - | _ -> error - end - | Pfctiwz(rd, r1) -> - begin match ecode with - | FCTIWZx(frD0, frB0, rc0) :: es -> - OK(fw) - >>= match_fregs rd frD0 - >>= match_fregs r1 frB0 - >>= match_bools false rc0 - >>= recur_simpl - | _ -> error - end - | Pfdiv(rd, r1, r2) -> - begin match ecode with - | FDIVx(frD, frA, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfdivs(rd, r1, r2) -> - begin match ecode with - | FDIVSx(frD, frA, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfmake(rd, r1, r2) -> - error - | Pfmr(rd, r1) -> - begin match ecode with - | FMRx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfmul(rd, r1, r2) -> - begin match ecode with - | FMULx(frD, frA, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfmuls(rd, r1, r2) -> - begin match ecode with - | FMULSx(frD, frA, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfneg(rd, r1) | Pfnegs(rd, r1) -> - begin match ecode with - | FNEGx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfreeframe(sz, ofs) -> - error - | Pfrsp(rd, r1) -> - begin match ecode with - | FRSPx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfxdp(rd, r1) -> - error - | Pfsub(rd, r1, r2) -> - begin match ecode with - | FSUBx(frD, frA, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfsubs(rd, r1, r2) -> - begin match ecode with - | FSUBSx(frD, frA, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r2 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfmadd(rd, r1, r2, r3) -> - begin match ecode with - | FMADDx(frD, frA, frB, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r3 frB - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfmsub(rd, r1, r2, r3) -> - begin match ecode with - | FMSUBx(frD, frA, frB, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r3 frB - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfnmadd(rd, r1, r2, r3) -> - begin match ecode with - | FNMADDx(frD, frA, frB, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r3 frB - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfnmsub(rd, r1, r2, r3) -> - begin match ecode with - | FNMSUBx(frD, frA, frB, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r3 frB - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfsqrt(rd, r1) -> - begin match ecode with - | FSQRTx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfrsqrte(rd, r1) -> - begin match ecode with - | FRSQRTEx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfres(rd, r1) -> - begin match ecode with - | FRESx(frD, frB, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pfsel(rd, r1, r2, r3) -> - begin match ecode with - | FSELx(frD, frA, frB, frC, rc) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_fregs r1 frA - >>= match_fregs r3 frB - >>= match_fregs r2 frC - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pisync -> - begin match ecode with - | ISYNC :: es -> - OK(fw) - >>= recur_simpl - | _ -> error - end - | Plabel(lbl) -> - OK(fw) - >>= lblmap_unify lbl pc - >>^ (fun fw -> {fw with label_list = lbl :: fw.label_list}) - >>= compare_code cs ecode pc - | Plbz(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | LBZ(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Plbz(rd, cst, r1) -> - begin match ecode with - | LBZ(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_csts cst (exts d) - >>= match_iregs r1 rA - >>= recur_simpl - | _ -> error - end - | Plbzx(rd, r1, r2) -> - begin match ecode with - | LBZX(rD, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plfd(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | LFD(frD, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Plfd(rd, cst, r1) | Plfd_a(rd, cst, r1) -> - begin match ecode with - | LFD(frD, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_csts cst (exts d) - >>= match_iregs r1 rA - >>= recur_simpl - | _ -> error - end - | Plfdx(rd, r1, r2) | Plfdx_a(rd, r1, r2) -> - begin match ecode with - | LFDX(frD, rA, rB) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plfi(r1, c) -> - begin match ecode with - | ADDIS(rD0, rA0, simm0) :: - LFD (frD1, rA1, d1) :: es -> - let vaddr = Int32.( - add (shift_left (Safe32.of_int simm0) 16) (exts d1) - ) in - if Int32.rem vaddr 8l <> 0l - then ERR("Float constants should be 8-byte aligned") - else - let elf = fw.sf.ef.elf in - let atom = Hashtbl.find fw.sf.atoms fw.this_ident in - let literal_section = - begin match atom.a_sections with - | [_; l; _] -> l - | _ -> Section_literal - end - in - let continue = compare_code cs es (Int32.add 8l pc) in - begin match bitstring_at_vaddr elf vaddr 8l with - | None -> - ERR("Floating point constant address is wrong") - | Some(bs, pofs, psize) -> - let f = - bitmatch bs with - | { f : 64 : int } -> f - in - OK(fw) - >>= (fun ffw -> - begin match section_at_vaddr elf vaddr with - | None -> ERR("No section at that virtual address") - | Some(sndx) -> - let section_name = elf.e_shdra.(sndx).sh_name in - OK( - ffw - >>> ( - ff_sf ^%= - match_sections_name literal_section section_name - ) - ) - end - ) - >>= match_iregs GPR12 rD0 - >>= match_iregs GPR0 rA0 - >>= match_fregs r1 frD1 - >>= match_floats c f - >>^ (ff_ef ^%= add_range pofs psize 8 (Float_literal(f))) - >>= match_iregs GPR12 rA1 - >>= continue - end - | _ -> error - end - | Plfis(r1, c) -> - begin match ecode with - | ADDIS(rD0, rA0, simm0) :: - LFS (frD1, rA1, d1) :: es -> - let vaddr = Int32.( - add (shift_left (Safe32.of_int simm0) 16) (exts d1) - ) in - if Int32.rem vaddr 4l <> 0l - then ERR("Float32 constants should be 4-byte aligned") - else - let elf = fw.sf.ef.elf in - let atom = Hashtbl.find fw.sf.atoms fw.this_ident in - let literal_section = - begin match atom.a_sections with - | [_; l; _] -> l - | _ -> Section_literal - end - in - let continue = compare_code cs es (Int32.add 8l pc) in - begin match bitstring_at_vaddr elf vaddr 4l with - | None -> - ERR("Floating point constant address is wrong") - | Some(bs, pofs, psize) -> - let f = - bitmatch bs with - | { f : 32 : int } -> f - in - OK(fw) - >>= (fun ffw -> - begin match section_at_vaddr elf vaddr with - | None -> ERR("No section at that virtual address") - | Some(sndx) -> - let section_name = elf.e_shdra.(sndx).sh_name in - OK( - ffw - >>> ( - ff_sf ^%= - match_sections_name literal_section section_name - ) - ) - end - ) - >>= match_iregs GPR12 rD0 - >>= match_iregs GPR0 rA0 - >>= match_fregs r1 frD1 - >>= match_floats32 c f - >>^ (ff_ef ^%= add_range pofs psize 4 (Float32_literal(f))) - >>= match_iregs GPR12 rA1 - >>= continue - end - | _ -> error - end - | Plfs(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | LFS(frD, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Plfs(rd, cst, r1) -> - begin match ecode with - | LFS(frD, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_csts cst (exts d) - >>= match_iregs r1 rA - >>= recur_simpl - | _ -> error - end - | Plfsx(rd, r1, r2) -> - begin match ecode with - | LFSX(frD, rA, rB) :: es -> - OK(fw) - >>= match_fregs rd frD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plha(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | LHA(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Plha(rd, cst, r1) -> - begin match ecode with - | LHA(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_csts cst (exts d) - >>= match_iregs r1 rA - >>= recur_simpl - | _ -> error - end - | Plhax(rd, r1, r2) -> - begin match ecode with - | LHAX(rD, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plhbrx(rd, r1, r2) -> - begin match ecode with - | LHBRX(rD, rA, rB):: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plhz(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | LHZ(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Plhz(rd, cst, r1) -> - begin match ecode with - | LHZ(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_csts cst (exts d) - >>= match_iregs r1 rA - >>= recur_simpl - | _ -> error - end - | Plhzx(rd, r1, r2) -> - begin match ecode with - | LHZX(rD, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plwarx(rd, r1, r2) -> - begin match ecode with - | LWARX(rD, rA, rB):: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plwbrx(rd, r1, r2) -> - begin match ecode with - | LWBRX(rD, rA, rB):: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Plwz(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | LWZ(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Plwz(rd, cst, r1) | Plwz_a(rd, cst, r1) -> - begin match ecode with - | LWZ(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Plwzu(rd, cst, r1) -> - begin match ecode with - | LWZU(rD, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Plwzx(rd, r1, r2) | Plwzx_a(rd, r1, r2) -> - begin match ecode with - | LWZX(rD, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pmfcr rd -> - begin match ecode with - | MFCR (rD0) :: es -> - OK(fw) - >>= match_iregs rd rD0 - >>= recur_simpl - | _ -> error - end - | Pmfcrbit(rd, bit) -> - error - | Pmflr(r) -> - begin match ecode with - | MFSPR(rD, spr) :: es -> - OK(fw) - >>= match_iregs r rD - >>= match_lr spr - >>= recur_simpl - | _ -> error - end - | Pmr(rd, r1) -> - begin match ecode with - | ORx(rS, rA, rB, rc) :: es when (rB = rS) -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pmtctr(r1) -> - begin match ecode with - | MTSPR(rS, spr) :: es -> - OK(fw) - >>= match_iregs r1 rS - >>= match_ctr spr - >>= recur_simpl - | _ -> error - end - | Pmtlr(r1) -> - begin match ecode with - | MTSPR(rS, spr) :: es -> - OK(fw) - >>= match_iregs r1 rS - >>= match_lr spr - >>= recur_simpl - | _ -> error - end - | Pmulli(rd, r1, cst) -> - begin match ecode with - | MULLI(rD, rA, simm) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (exts simm) - >>= recur_simpl - | _ -> error - end - | Pmullw(rd, r1, r2) -> - begin match ecode with - | MULLWx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pmulhw(rd, r1, r2) -> - begin match ecode with - | MULHWx(rD, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pmulhwu(rd, r1, r2) -> - begin match ecode with - | MULHWUx(rD, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pnand(rd, r1, r2) -> - begin match ecode with - | NANDx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pnor(rd, r1, r2) -> - begin match ecode with - | NORx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Por(rd, r1, r2) -> - begin match ecode with - | ORx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Porc(rd, r1, r2) -> - begin match ecode with - | ORCx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pori(rd, r1, cst) -> - begin match ecode with - | ORI(rS, rA, uimm) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_csts cst (Safe32.of_int uimm) - >>= recur_simpl - | _ -> error - end - | Poris(rd, r1, cst) -> - begin match ecode with - | ORIS(rS, rA, uimm) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_csts cst (Safe32.of_int uimm) - >>= recur_simpl - | _ -> error - end - | Prlwimi(rd, r1, amount, mask) -> - begin match ecode with - | RLWIMIx(rS, rA, sh, mb, me, rc) :: es -> - OK(fw) - >>= match_iregs r1 rS - >>= match_iregs rd rA - >>= match_z_int amount sh - >>= match_mask mask (bitmask mb me) - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Prlwinm(rd, r1, amount, mask) -> - begin match ecode with - | RLWINMx(rS, rA, sh, mb, me, rc) :: es -> - OK(fw) - >>= match_iregs r1 rS - >>= match_iregs rd rA - >>= match_z_int amount sh - >>= match_mask mask (bitmask mb me) - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pslw(rd, r1, r2) -> - begin match ecode with - | SLWx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Psraw(rd, r1, r2) -> - begin match ecode with - | SRAWx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Psrawi(rd, r1, n) -> - begin match ecode with - | SRAWIx(rS, rA, sh, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_z_int n sh - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Psrw(rd, r1, r2) -> - begin match ecode with - | SRWx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pstb(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | STB(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Pstb(rd, cst, r1) -> - begin match ecode with - | STB(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Pstbx(rd, r1, r2) -> - begin match ecode with - | STBX(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pstfd(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | STFD(frS, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Pstfd(rd, cst, r1) | Pstfd_a(rd, cst, r1) -> - begin match ecode with - | STFD(frS, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Pstfdu(rd, cst, r1) -> - begin match ecode with - | STFDU(frS, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Pstfdx(rd, r1, r2) | Pstfdx_a(rd, r1, r2) -> - begin match ecode with - | STFDX(frS, rA, rB) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pstfs(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | STFS(frS, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Pstfs(rd, cst, r1) -> - begin match ecode with - | STFS(frS, rA, d) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Pstfsx(rd, r1, r2) -> - begin match ecode with - | STFSX(frS, rA, rB) :: es -> - OK(fw) - >>= match_fregs rd frS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Psth(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | STH(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Psth(rd, cst, r1) -> - begin match ecode with - | STH(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Psthx(rd, r1, r2) -> - begin match ecode with - | STHX(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Psthbrx(rd, r1, r2) -> - begin match ecode with - | STHBRX(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pstw(rd, Csymbol_sda(ident, ofs), r1) -> - begin match ecode with - | STW(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= check_sda ident ofs rA (exts d) - >>= recur_simpl - | _ -> error - end - | Pstw(rd, cst, r1) | Pstw_a(rd, cst, r1) -> - begin match ecode with - | STW(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Pstwu(rd, cst, r1) -> - begin match ecode with - | STWU(rS, rA, d) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_csts cst (exts d) - >>= recur_simpl - | _ -> error - end - | Pstwx(rd, r1, r2) | Pstwx_a(rd, r1, r2) -> - begin match ecode with - | STWX(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pstwbrx(rd, r1, r2) -> - begin match ecode with - | STWBRX(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pstwcx_(rd, r1, r2) -> - begin match ecode with - | STWCX_(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Pstwux(rd, r1, r2) -> - begin match ecode with - | STWUX(rS, rA, rB) :: es -> - OK(fw) - >>= match_iregs rd rS - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= recur_simpl - | _ -> error - end - | Psubfc(rd, r1, r2) -> - begin match ecode with - | SUBFCx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Psubfe(rd, r1, r2) -> - begin match ecode with - | SUBFEx(rD, rA, rB, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_iregs r2 rB - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Psubfze(rd, r1) -> - begin match ecode with - | SUBFZEx(rD, rA, oe, rc) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_bools false oe - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Psubfic(rd, r1, cst) -> - begin match ecode with - | SUBFIC(rD, rA, simm) :: es -> - OK(fw) - >>= match_iregs rd rD - >>= match_iregs r1 rA - >>= match_csts cst (exts simm) - >>= recur_simpl - | _ -> error - end - | Psync -> - begin match ecode with - | SYNC :: es -> - OK(fw) - >>= recur_simpl - | _ -> error - end - | Ptrap -> - begin match ecode with - | TW(tO, rA, rB) :: es -> - OK(fw) - >>= (fun ffw -> - bitmatch tO with - | { 31 : 5 : int } -> OK(ffw) - | { _ } -> ERR("bitmatch") - ) - >>= match_iregs GPR0 rA - >>= match_iregs GPR0 rB - >>= recur_simpl - | _ -> error - end - | Pxor(rd, r1, r2) -> - begin match ecode with - | XORx(rS, rA, rB, rc) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_iregs r2 rB - >>= match_bools false rc - >>= recur_simpl - | _ -> error - end - | Pxori(rd, r1, cst) -> - begin match ecode with - | XORI(rS, rA, uimm) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_csts cst (Safe32.of_int uimm) - >>= recur_simpl - | _ -> error - end - | Pxoris(rd, r1, cst) -> - begin match ecode with - | XORIS(rS, rA, uimm) :: es -> - OK(fw) - >>= match_iregs rd rA - >>= match_iregs r1 rS - >>= match_csts cst (Safe32.of_int uimm) - >>= recur_simpl - | _ -> error - end - -(** A work element is a triple giving a CompCert ident for the function to - analyze, its name as a string, and the actual code. It is not obvious how - to recover one of the three components given the other two. -*) -type worklist = (ident * string * ccode) list - -(** Pops a work element from the worklist, ensuring that fully-determined idents - (i.e. those for which the possible virtual address have been narrowed to one - candidate) are picked first. - When the first element is not fully-determined, the whole list is sorted so - that hopefully several fully-determined idents are brought at the beginning - at the same time. -*) -let worklist_pop fw wl = - match wl with - | [] -> None - | h::t -> - let (i, _, _) = h in - let candidates = - try PosMap.find i fw.ident_to_sym_ndx - with Not_found -> [] - in - match candidates with - | [] | [_] -> Some (h, t, candidates) - | _ -> - let wl = List.fast_sort - (fun (i1, _, _) (i2, _, _) -> - compare - (List.length (PosMap.find i1 fw.ident_to_sym_ndx)) - (List.length (PosMap.find i2 fw.ident_to_sym_ndx))) - wl in - let winner = List.hd wl in - let (i, _, _) = winner in - Some (winner, List.tl wl, PosMap.find i fw.ident_to_sym_ndx) - -(** Processes a worklist, threading in the framework. -*) -let rec worklist_process (wl: worklist) sfw: s_framework = - match worklist_pop sfw wl with - | None -> sfw (*done*) - | Some ((ident, name, ccode), wl, candidates) -> - let process_ndx ndx = ( - let elf = (sfw |. sf_ef).elf in - let pc = elf.e_symtab.(ndx).st_value in - match code_of_sym_ndx elf ndx with - | None -> ERR("Could not find symbol data for function symbol " ^ name) - | Some ecode -> - sfw - >>> sf_ef ^%= - add_log (DEBUG("Processing function: " ^ name)) - >>> (fun sfw -> - { - sf = sfw; - this_sym_ndx = ndx; - this_ident = ident; - label_to_vaddr = PosMap.empty; - label_list = []; - } - ) - >>> compare_code ccode.fn_code ecode pc - >>^ mark_covered_fun_sym_ndx ndx - ) in - begin match candidates with - | [] -> - sfw - >>> sf_ef ^%= - add_log (ERROR("Skipping missing symbol " ^ name)) - >>> worklist_process wl - | [ndx] -> - begin match process_ndx ndx with - | OK(ffw) -> - ffw - >>> check_label_existence - >>> check_label_unicity - >>> (fun ffw -> - worklist_process wl ffw.sf - ) - | ERR(s) -> - sfw - >>> sf_ef ^%= - add_log (ERROR( - Printf.sprintf - "Unique candidate for %s did not match: %s" - name - s - )) - >>> worklist_process wl - end - | ndxes -> - (* Multiple candidates for one symbol *) - let fws = filter_ok (List.map process_ndx ndxes) in - begin match fws with - | [] -> - sfw - >>> sf_ef ^%= - add_log (ERROR("No matching candidate for: " ^ name)) - >>> worklist_process wl - | [ffw] -> - worklist_process wl ffw.sf - | fws -> - sfw - >>> sf_ef ^%= - add_log (ERROR( - "Multiple matching candidates for: " ^ name - )) - >>> worklist_process wl - end - end - -(** Compares a data symbol with its expected contents. Returns the updated - framework as well as the size of the data matched. -**) -let compare_data (l: init_data list) (bs: bitstring) (sfw: s_framework) - : (s_framework * int) or_err = - let error = ERR("Reached end of data bitstring too soon") in - let rec compare_data_aux l bs s (sfw: s_framework): - (s_framework * int) or_err = - match l with - | [] -> OK(sfw, s) - | d::l -> - let sfw = - if !debug - then ( - (sf_ef ^%= add_log (DEBUG(" " ^ string_of_init_data d))) sfw - ) - else sfw - in - begin match d with - | Init_int8(i) -> ( - bitmatch bs with - | { j : 8 : int; bs : -1 : bitstring } -> - if (z_int_lax i) land 0xFF = j - then compare_data_aux l bs (s + 1) sfw - else ERR("Wrong int8") - | { _ } -> error - ) - | Init_int16(i) -> ( - bitmatch bs with - | { j : 16 : int; bs : -1 : bitstring } -> - if (z_int_lax i) land 0xFFFF = j - then compare_data_aux l bs (s + 2) sfw - else ERR("Wrong int16") - | { _ } -> error - ) - | Init_int32(i) -> ( - bitmatch bs with - | { j : 32 : int; bs : -1 : bitstring } -> - if z_int32_lax i = j - then compare_data_aux l bs (s + 4) sfw - else ERR("Wrong int32") - | { _ } -> error - ) - | Init_float32(f) -> ( - bitmatch bs with - | { j : 32 : int; bs : -1 : bitstring } -> - if camlint_of_coqint (Floats.Float32.to_bits f) = j - then compare_data_aux l bs (s + 4) sfw - else ERR("Wrong float32") - | { _ } -> error - ) - | Init_float64(f) -> ( - bitmatch bs with - | { j : 64 : int; bs : -1 : bitstring } -> - if camlint64_of_coqint (Floats.Float.to_bits f) = j - then compare_data_aux l bs (s + 8) sfw - else ERR("Wrong float64") - | { _ } -> error - ) - | Init_int64(i) -> ( - bitmatch bs with - | { j : 64 : int; bs : -1 : bitstring } -> - if z_int64 i = j - then compare_data_aux l bs (s + 8) sfw - else ERR("Wrong int64") - | { _ } -> error - ) - | Init_space(z) -> ( - let space_size = z_int z in - bitmatch bs with - | { space : space_size * 8 : bitstring; bs : -1 : bitstring } -> - if is_zeros space (space_size * 8) - then compare_data_aux l bs (s + space_size) sfw - else ERR("Wrong space " ^ - string_of_int (z_int z) ^ " " ^ - string_of_bitstring space) - | { _ } -> error - ) - | Init_addrof(ident, ofs) -> ( - bitmatch bs with - | { vaddr : 32 : int; bs : -1 : bitstring } -> - sfw - >>> idmap_unify ident (Int32.sub vaddr (z_int32 ofs)) - >>= compare_data_aux l bs (s + 4) - | { _ } -> error - ) - end - in - compare_data_aux l bs 0 sfw - -(** Checks the data symbol table. -*) -let check_data_symtab ident sym_ndx size sfw = - let elf = sfw.ef.elf in - let symtab_ent_start = Int32.( - add - elf.e_shdra.(elf.e_symtab_sndx).sh_offset - (Safe32.of_int (16 * sym_ndx)) - ) in - let sym = sfw.ef.elf.e_symtab.(sym_ndx) in - let atom = Hashtbl.find sfw.atoms ident in - let section = - match atom.a_sections with - | [s] -> s - | _ -> Section_data true - in - sfw - >>> ( - if sym.st_size = Safe32.of_int size - then id - else ( - sf_ef ^%= - add_log (ERROR( - "Incorrect symbol size (" ^ sym.st_name ^ - "): expected " ^ string_of_int32i sym.st_size ^ - ", counted: " ^ string_of_int size - )) - ) - ) - >>> check_st_bind atom sym - >>> ( - match sym.st_type with - | STT_OBJECT -> id - | STT_NOTYPE -> (sf_ef ^%= - add_log (WARNING("Missing type for symbol " ^ sym.st_name)) - ) - | _ -> (sf_ef ^%= - add_log (ERROR("Symbol should have type STT_OBJECT")) - ) - ) - >>> ( - if sym.st_other = 0 - then id - else (sf_ef ^%= - add_log (ERROR("Symbol should have st_other set to 0")) - ) - ) - >>> match_sections_name section elf.e_shdra.(sym.st_shndx).sh_name - >>> (sf_ef ^%= - add_range symtab_ent_start 16l 4 (Symtab_data(sym)) - ) - -(** Checks all the program variables. -*) -let check_data (pv: (ident * unit globvar) list) (sfw: s_framework) - : s_framework = - let process_ndx ident ldata sfw ndx = - let elf = sfw.ef.elf in - let sym = elf.e_symtab.(ndx) in - let sym_vaddr = sym.st_value in - begin match bitstring_at_vaddr_nosize elf sym_vaddr with - | None -> ERR("Could not find symbol data for data symbol " ^ sym.st_name) - | Some(sym_bs, pofs, psize) -> - let res = - sfw - >>> (sf_ef ^%= add_log (DEBUG("Processing data: " ^ sym.st_name))) - >>> compare_data ldata sym_bs - in - begin match res with - | ERR(s) -> ERR(s) - | OK(sfw, size) -> - let align = - begin match (Hashtbl.find sfw.atoms ident).a_alignment with - | None -> 0 - | Some(a) -> a - end - in - sfw.ef.chkd_data_syms.(ndx) <- true; - OK(sfw) - >>= (fun sfw -> - if size = 0 - then OK(sfw) (* These occupy no space, for now we just forget them *) - else OK( - sfw - >>> sf_ef ^%= - add_range pofs (Safe32.of_int size) align (Data_symbol(sym)) - ) - ) - >>= (fun sfw -> - if not (is_well_aligned sym_vaddr align) - then ERR("Symbol not correctly aligned in the ELF file") - else OK(sfw) - ) - >>^ check_data_symtab ident ndx size - end - end - in - let check_data_aux sfw ig = - let (ident, gv) = ig in - let init_data = gv.gvar_init in - let ident_ndxes = PosMap.find ident sfw.ident_to_sym_ndx in - (*print_endline ("Candidates: " ^ string_of_list id ", " - (List.map - (fun ndx -> fw.elf.e_symtab.(ndx).st_name) - ident_ndxes));*) - let results = List.map (process_ndx ident init_data sfw) ident_ndxes in - let successes = filter_ok results in - match successes with - | [] -> - sfw - >>> sf_ef ^%= - add_log (ERROR( - "No matching data segment among candidates [" ^ - (string_of_list - (fun ndx -> sfw.ef.elf.e_symtab.(ndx).st_name) - ", " - ident_ndxes - ) ^ - "], Errors: [" ^ - string_of_list - (function OK(_) -> "" | ERR(s) -> s) - ", " - (List.filter (function ERR(_) -> true | _ -> false) results) - ^ "]" - )) - | [sfw] -> sfw - | fws -> - sfw - >>> sf_ef ^%= add_log (ERROR("Multiple matching data segments!")) - in - List.fold_left check_data_aux sfw - (* Empty lists mean the symbol is external, no need for check *) - (List.filter (fun (_, gv) -> gv.gvar_init <> []) pv) - -(** Read a .sdump file *) - -let sdump_magic_number = "CompCertSDUMP" ^ Version.version - -let read_sdump file = - let ic = open_in_bin file in - try - let magic = String.create (String.length sdump_magic_number) in - really_input ic magic 0 (String.length sdump_magic_number); - if magic <> sdump_magic_number then fatal "Bad magic number"; - let prog = (input_value ic: Asm.program) in - let names = (input_value ic: (ident, string) Hashtbl.t) in - let atoms = (input_value ic: (ident, C2C.atom_info) Hashtbl.t) in - close_in ic; - (prog, names, atoms) - with - | End_of_file -> - close_in ic; Printf.eprintf "Truncated file %s\n" file; exit 2 - | Failure msg -> - close_in ic; Printf.eprintf "Corrupted file %s: %s\n" file msg; exit 2 - -(** Split program definitions into functions and variables *) - -let split_prog_defs p = - let rec split fns vars = function - | [] -> (List.rev fns, List.rev vars) - | (id, Gfun fd) :: defs -> split ((id, fd) :: fns) vars defs - | (id, Gvar vd) :: defs -> split fns ((id, vd) :: vars) defs - in split [] [] p.prog_defs - -(** Processes a .sdump file. -*) -let process_sdump efw sdump: e_framework = - print_debug ("Beginning reading " ^ sdump); - let (prog, names, atoms) = read_sdump sdump in - let (prog_funct, prog_vars) = split_prog_defs prog in - print_debug ("Constructing mapping from idents to symbol indices"); - let ident_to_sym_ndx = - Hashtbl.fold - (fun ident name m -> - match ndxes_of_sym_name efw.elf name with - | [] -> m (* skip if missing *) - | ndxes -> PosMap.add ident ndxes m - ) - names - PosMap.empty - in - print_debug("Constructing worklist"); - let worklist_fundefs = - List.filter - (fun f -> - match snd f with - | Internal _ -> true - | External _ -> false - ) - prog_funct - in - let wl = - List.map - (fun f -> - match f with - | ident, Internal ccode -> (ident, Hashtbl.find names ident, ccode) - | _, External _ -> fatal "IMPOSSIBRU!" - ) - worklist_fundefs - in - print_debug("Beginning processing of the worklist"); - efw - >>> (fun efw -> - { ef = efw - ; program = prog - ; ident_to_name = names - ; ident_to_sym_ndx = ident_to_sym_ndx - ; atoms = atoms - } - ) - >>> worklist_process wl - >>> (fun sfw -> - print_debug "Checking data"; - sfw - ) - >>> check_data prog_vars - >>> (fun sfw -> sfw.ef) - -(** Returns true if [a, b] intersects [ofs, ofs + size - 1]. *) -let intersect (a, b) ofs size: bool = - let within (a, b) x = (a <= x) && (x <= b) in - (within (a, b) ofs) || (within (ofs, Int32.(sub (add ofs size) 1l)) a) - -let string_of_range a b = "[0x" ^ Printf.sprintf "%08lx" a ^ " - 0x" ^ - Printf.sprintf "%08lx" b ^ "]" - -(** Checks that the bits from [start] to [stop] in [bs] are zeroed. *) -let is_padding bs start stop = - let bs_start = start * 8 in - let bs_length = (stop - start + 1) * 8 in - start <= stop && - is_zeros (Bitstring.subbitstring bs bs_start bs_length) bs_length - -(** This functions goes through the list of checked bytes, and tries to find - padding in it. That is, it takes pairs of chunks in order, and adds a - padding chunk in between if these conditions are met: - - - the second chunk needs to be aligned. - - - the difference between the two chunks is strictly less than the alignment. - - - the data in this space is zeroed. - - Otherwise, it fills holes with an Unknown chunk. - Returns a framework where [chkd_bytes_list] is sorted and full. -*) -let check_padding efw = - print_debug "Checking padding"; - let elf = efw.elf in - let sndxes = list_n elf.e_hdr.e_shnum in - let matching_sections x y = - string_of_list - id - ", " - (List.map - (fun ndx -> elf.e_shdra.(ndx).sh_name) - (List.filter - (fun ndx -> - let shdr = elf.e_shdra.(ndx) in - intersect (x, y) shdr.sh_offset shdr.sh_size - ) - sndxes - ) - ) - in - let matching_symbols x y = - string_of_list - id - ", " - (List.map - (fun sym -> sym.st_name) - (List.filter - (fun sym -> - if sym.st_shndx >= Array.length elf.e_shdra - then false (* special section *) - else - match physical_offset_of_vaddr elf sym.st_value with - | None -> false - | Some(ofs) -> intersect (x, y) ofs sym.st_size - ) - (Array.to_list elf.e_symtab) - ) - ) - in - let unknown x y = Unknown( - "\nSections: " ^ matching_sections x y ^ "\nSymbols: " ^ matching_symbols x y - ) - in - (* check_padding_aux assumes a sorted list *) - let rec check_padding_aux efw accu l = - match l with - | [] -> efw - (* if there is only one chunk left, we add an unknown space between it and - the end. *) - | [(_, e, _, _) as h] -> - let elf_size = - Safe32.of_int ((Bitstring.bitstring_length efw.elf.e_bitstring) / 8) in - let elf_end = Int32.sub elf_size 1l in - if e = elf_end - then { efw with - chkd_bytes_list = List.rev (h :: accu); - } - else ( - let start = Int32.add e 1l in - { efw with - chkd_bytes_list = List.rev - ((start, elf_end, 0, unknown start elf_end) :: h :: accu); - } - ) - | ((b1, e1, a1, n1) as h1) :: ((b2, e2, a2, n2) as h2) :: rest -> - let pad_start = Int32.add e1 1l in - let pad_stop = Int32.sub b2 1l in - if pad_start = b2 (* if they are directly consecutive *) - || Safe.(of_int32 b2 - of_int32 e1) > a2 (* or if they are too far away *) - || not (is_padding efw.elf.e_bitstring - (Safe32.to_int pad_start) (Safe32.to_int pad_stop)) - then (* not padding *) - if pad_start <= pad_stop - then - check_padding_aux efw - ((pad_start, pad_stop, 0, unknown pad_start pad_stop) :: h1 :: accu) - (h2 :: rest) - else - check_padding_aux efw (h1 :: accu) (h2 :: rest) - else ( (* this is padding! *) - check_padding_aux efw - ((pad_start, pad_stop, 0, Padding) :: h1 :: accu) - (h2 :: rest) - ) - in - let sorted_chkd_bytes_list = - List.fast_sort - (fun (a, _, _, _) (b, _, _, _) -> Int32.compare a b) - efw.chkd_bytes_list - in check_padding_aux efw [] sorted_chkd_bytes_list - -(** Checks a boolean. *) -let ef_checkb b msg = - if b then id else add_log(ERROR(msg)) - -let check_elf_identification efw = - let ei = efw.elf.e_hdr.e_ident in - efw - >>> ef_checkb (ei.ei_class = ELFCLASS32) "ELF class should be ELFCLASS32" - >>> ef_checkb (ei.ei_data = ELFDATA2MSB || ei.ei_data = ELFDATA2LSB) - "ELF should be MSB or LSB" - >>> ef_checkb (ei.ei_version = EV_CURRENT) - "ELF identification version should be EV_CURRENT" - -let check_elf_header efw: e_framework = - let eh = efw.elf.e_hdr in - efw - >>> check_elf_identification - >>> ef_checkb (eh.e_type = ET_EXEC) "ELF type should be ET_EXEC" - >>> ef_checkb (eh.e_machine = EM_PPC) "ELF machine should be PPC" - >>> ef_checkb (eh.e_version = EV_CURRENT) "ELF version should be EV_CURRENT" - >>> add_range 0l 52l 0 ELF_header (* Header is always 52-bytes long *) - -(** Checks the index 0 of the symbol table. This index is reserved to hold - special values. *) -let check_sym_tab_zero efw = - let elf = efw.elf in - let sym0 = efw.elf.e_symtab.(0) in - (* First, let's mark it checked as a data symbol, to avoid warnings *) - efw.chkd_data_syms.(0) <- true; - efw - >>> ( - if sym0.st_name = "" - then id - else add_log (ERROR("Symbol 0 should not have a name")) - ) - >>> ( - if sym0.st_value = 0l - then id - else add_log (ERROR("Symbol 0 should have st_value = 0")) - ) - >>> ( - if sym0.st_size = 0l - then id - else add_log (ERROR("Symbol 0 should have st_size = 0")) - ) - >>> ( - if sym0.st_bind = STB_LOCAL - then id - else add_log (ERROR("Symbol 0 should have STB_LOCAL binding")) - ) - >>> ( - if sym0.st_type = STT_NOTYPE - then id - else add_log (ERROR("Symbol 0 should have STT_NOTYPE type")) - ) - >>> ( - if sym0.st_other = 0 - then id - else add_log (ERROR("Symbol 0 should have st_other = 0")) - ) - >>> ( - if sym0.st_shndx = shn_UNDEF - then id - else add_log (ERROR("Symbol 0 should have st_shndx = SHN_UNDEF")) - ) - >>> add_range elf.e_shdra.(elf.e_symtab_sndx).sh_offset 16l 4 Zero_symbol - -(** If CompCert sections have been mapped to an ELF section whose name is - not the same, we warn the user. -*) -let warn_sections_remapping efw = - print_debug "Checking remapped sections"; - StringMap.fold - (fun c_name (e_name, conflicts) efw -> - if c_name = "COMM" then efw else - if StringSet.is_empty conflicts - then - match e_name with - | Provided(e_name) -> - efw - | Inferred(e_name) -> - if c_name = e_name - then efw - else - begin - efw - >>> add_log (WARNING( - Printf.sprintf - "Detected linker script remapping: section %S -> %S" - c_name e_name - )) - end - else (* conflicts not empty *) - match e_name with - | Provided(e_name) -> - efw - >>> add_log (ERROR( - Printf.sprintf " - Conflicting remappings for section %s: - Specified: %s - Expected: %s" - c_name e_name (string_of_list id ", " (StringSet.elements conflicts)) - )) - | Inferred(e_name) -> - efw - >>> add_log (ERROR( - Printf.sprintf " - Conflicting remappings for section %s: - %s" - c_name (string_of_list id ", " (e_name :: (StringSet.elements conflicts))) - )) - ) - efw.section_map - efw - -let warn_sda_mapping efw = - print_debug "Checking SDA mappings"; - if IntMap.is_empty efw.sda_map - then efw - else ( - IntMap.fold - (fun r vaddr efw -> - match vaddr with - | Provided(_) -> efw - | Inferred(vaddr) -> - efw >>> add_log (WARNING( - Printf.sprintf - "This SDA register mapping was inferred: register r%u = 0x%lX" - r vaddr - )) - ) - efw.sda_map - efw - ) - -let (>>=) li f = List.flatten (List.map f li) - -(** Returns the list of all strictly-ordered pairs of [[0; len - 1]] that don't - satisfy f. *) -let forall_sym (len: int) (f: 'a -> 'a -> bool): ('a * 'a) list = - (list_n len) >>= fun x -> - (list_ab (x + 1) (len - 1)) >>= fun y -> - (if f x y then [] else [(x, y)]) - -let check_overlaps efw = - let shdra = efw.elf.e_shdra in - let intersect a asize b bsize = - asize <> 0l && bsize <> 0l && - ( - let last x xsize = Int32.(sub (add x xsize) 1l) in - let alast = last a asize in - let blast = last b bsize in - let within (a, b) x = (a <= x) && (x <= b) in - (within (a, alast) b) || (within (b, blast) a) - ) - in - match - forall_sym (Array.length shdra) - (fun i j -> - let ai = shdra.(i) in - let aj = shdra.(j) in - (ai.sh_type = SHT_NOBITS) - || (aj.sh_type = SHT_NOBITS) - || (not (intersect ai.sh_offset ai.sh_size aj.sh_offset aj.sh_size)) - ) - with - | [] -> efw - | l -> - List.fold_left - (fun efw (i, j) -> - let msg = - Printf.sprintf "Sections %s and %s overlap" shdra.(i).sh_name shdra.(j).sh_name - in - add_log (ERROR(msg)) efw - ) - efw l - -let check_unknown_chunks efw = - if - List.exists - (function (_, _, _, Unknown(_)) -> true | _ -> false) - efw.chkd_bytes_list - then add_log (WARNING( - "Some parts of the ELF file are unknown." ^ - (if !print_elfmap then "" else " Use -print-elfmap to see what was covered.") - )) efw - else efw - -let check_missed_symbols efw = - if not !exhaustivity - then efw - else - let chkd_syms_a = - Array.init - (Array.length efw.elf.e_symtab) - ( - fun ndx -> - match efw.elf.e_symtab.(ndx).st_type with - (* we only care about function and data symbols *) - | STT_SECTION | STT_FILE -> true - | STT_OBJECT | STT_FUNC | STT_NOTYPE | STT_UNKNOWN -> - (* checked as either a function or a data symbol *) - efw.chkd_fun_syms.(ndx) - || efw.chkd_data_syms.(ndx) - (* or part of the symbols we know are mising *) - || StringSet.mem efw.elf.e_symtab.(ndx).st_name efw.missing_syms - ) - in - let missed_syms_l = list_false_indices chkd_syms_a in - match missed_syms_l with - | [] -> efw - | _ -> - let symtab = efw.elf.e_symtab in - let symlist_names = string_of_list (fun ndx -> symtab.(ndx).st_name) " " in - let missed_funs = - List.filter (fun ndx -> symtab.(ndx).st_type = STT_FUNC) missed_syms_l in - let missed_data = - List.filter (fun ndx -> symtab.(ndx).st_type = STT_OBJECT) missed_syms_l in - let missed_unknown = - List.filter (fun ndx -> - match symtab.(ndx).st_type with - | STT_NOTYPE | STT_UNKNOWN -> true - | _ -> false - ) missed_syms_l in - if !list_missing - then - efw - >>> add_log (WARNING( - Printf.sprintf - " - The following function symbol(s) do not appear in .sdump files: - %s - The following data symbols do not appear in .sdump files: - %s - The following unknown type symbols do not appear in .sdump files: - %s" - (symlist_names missed_funs) - (symlist_names missed_data) - (symlist_names missed_unknown) - )) - else - efw - >>> add_log (WARNING( - Printf.sprintf - "%u function symbol(s), %u data symbol(s) and %u unknown type symbol(s) do not appear in .sdump files. Add -list-missing to list them." - (List.length missed_funs) - (List.length missed_data) - (List.length missed_unknown) - )) - -let print_diagnosis efw = - let (nb_err, nb_warn) = List.fold_left - (fun (e, w) -> function - | DEBUG(_) -> (e, w) - | ERROR(_) -> (e + 1, w) - | INFO(_) -> (e, w) - | WARNING(_) -> (e, w + 1) - ) - (0, 0) - efw.log - in - if !debug - then Printf.printf "\n\nFINAL LOG:\n\n"; - List.(iter - (fun e -> - match string_of_log_entry false e with - | "" -> () - | s -> print_endline s - ) - (rev efw.log) - ); - let plural n = if n > 1 then "s" else "" in - Printf.printf " SUMMARY: %d error%s, %d warning%s\n" - nb_err (plural nb_err) nb_warn (plural nb_warn); - efw - -let conf_file = ref (None: string option) - -let parse_conf filename = - let section_map = ref StringMap.empty in - let sda_map = ref IntMap.empty in - let missing_syms = ref StringSet.empty in - let ic = open_in filename in - try - while true - do - let line = input_line ic in - (* Test different patterns one by one, until one of them works *) - let rec match_line = function - | [] -> failwith (Printf.sprintf "Couldn't read configuration line: %s" line) - | try_match::rest -> - try try_match () - with Scanf.Scan_failure(_) -> match_line rest - in - (* an empty line is ignored *) - if line <> "" - then - match_line - (* a comment *) - [ (fun () -> - Scanf.sscanf line - "#%s" - (fun _ -> ()) - ) - (* a section remapping *) - ; (fun () -> - Scanf.sscanf line - "section %S -> %S" - (fun sfrom sto -> - if StringMap.mem sfrom !section_map - then failwith ( - Printf.sprintf - "Your configuration file contains multiple mappings for section %s" - sfrom - ) - else - section_map := - StringMap.add sfrom (Provided(sto), StringSet.empty) !section_map - ) - ) - (* a SDA mapping *) - ; (fun () -> - Scanf.sscanf line - "register r%u = %li" - (fun r addr -> - if IntMap.mem r !sda_map - then failwith ( - Printf.sprintf - "Your configuration file contains multiple SDA mappings for register %u" - r - ) - else - sda_map := IntMap.add r (Provided(addr)) !sda_map) - ) - (* a list of symbols supposed to be missing from the .sdump files *) - ; (fun () -> - Scanf.sscanf line - "external %s@\n" - (fun sym_list_s -> - let sym_list = Str.split (Str.regexp "[ \t]+") sym_list_s in - List.iter - (fun sym -> missing_syms := StringSet.add sym !missing_syms) - sym_list - ) - ) - ] - done; raise End_of_file (* unreachable, just to please the typer *) - with - | End_of_file -> (!section_map, !sda_map, !missing_syms) - -(** Checks a whole ELF file according to a list of .sdump files. This never - dumps anything, so it can be safely used when fuzz-testing even if the - user accidentally enabled dumping options. *) -let check_elf_nodump elf sdumps = - let eh = elf.e_hdr in - let nb_syms = Array.length elf.e_symtab in - let section_strtab = elf.e_shdra.(eh.e_shstrndx) in - let symtab_shdr = elf.e_shdra.(elf.e_symtab_sndx) in - let symbol_strtab = elf.e_shdra.(Safe32.to_int symtab_shdr.sh_link) in - let (section_map, sda_map, missing_syms) = - match !conf_file with - | None -> (StringMap.empty, IntMap.empty, StringSet.empty) - | Some(filename) -> parse_conf filename - in - let efw = - { elf = elf - ; log = [] - ; chkd_bytes_list = [] - ; chkd_fun_syms = Array.make nb_syms false - ; chkd_data_syms = Array.make nb_syms false - ; section_map = section_map - ; sda_map = sda_map - ; missing_syms = missing_syms - } - >>> check_elf_header - >>> add_range - eh.e_phoff - Safe.(to_int32 (eh.e_phnum * eh.e_phentsize)) - 4 - ELF_progtab - >>> add_range - eh.e_shoff - Safe.(to_int32 (eh.e_shnum * eh.e_shentsize)) - 4 - ELF_shtab - >>> add_range - section_strtab.sh_offset - section_strtab.sh_size - 0 - ELF_section_strtab - >>> add_range - symbol_strtab.sh_offset - symbol_strtab.sh_size - 0 - ELF_symbol_strtab - >>> check_sym_tab_zero - in - print_debug "Done checking header, beginning processing of .sdumps"; - (* Thread the framework through the processing of all .sdump files *) - List.fold_left process_sdump efw sdumps - (* check the padding in between identified byte chunks *) - >>> check_padding - (* warn if some CompCert sections have been remapped by the linker script *) - >>> warn_sections_remapping - (* warn if there exists non-empty overlapping sections *) - >>> check_overlaps - (* warn about inferred SDA registers *) - >>> warn_sda_mapping - (* warn about regions of the ELF file that could not be identified *) - >>> check_unknown_chunks - >>> check_missed_symbols - >>> print_diagnosis - -(** Checks a whole ELF file according to .sdump files. - If requested, dump the calculated bytes mapping, so that it can be - reused by the fuzzer. *) -let check_elf_dump elffilename sdumps = - print_debug "Beginning ELF parsing"; - let elf = read_elf elffilename in - print_debug "Beginning ELF checking"; - let efw = check_elf_nodump elf sdumps in - (* print the elfmap if requested *) - if !print_elfmap - then - begin - Printf.printf "\n\n%s\n\n\n" - (string_of_list - (fun (a, b, align, r) -> string_of_range a b ^ " (" ^ - string_of_int align ^ ") " ^ string_of_byte_chunk_desc r) - "\n" - efw.chkd_bytes_list - ) - end; - (* dump the elfmap if requested *) - if !dump_elfmap - then - begin - let oc = open_out (elffilename ^ ".elfmap") in - output_value oc efw.chkd_bytes_list; - close_out oc - end diff --git a/checklink/Disassembler.ml b/checklink/Disassembler.ml deleted file mode 100644 index 0e2c6883..00000000 --- a/checklink/Disassembler.ml +++ /dev/null @@ -1,15 +0,0 @@ -open ELF_parsers -open ELF_types -open PPC_printers -open PPC_utils - -let disassemble elf sym_name = - let sym = - List.find - (fun sym -> sym.st_name = sym_name) - (Array.to_list elf.e_symtab) - in - match code_of_sym elf sym with - | None -> "Couldn't find the code for that symbol name" - | Some(ecode) -> - string_of_instr_list ecode diff --git a/checklink/ELF_parsers.ml b/checklink/ELF_parsers.ml deleted file mode 100644 index 8c2d486c..00000000 --- a/checklink/ELF_parsers.ml +++ /dev/null @@ -1,362 +0,0 @@ -open Bitstring_utils -open ELF_types -open ELF_printers -open ELF_utils -open Library -open PPC_parsers - -(** Allows relaxations of the parser: - - 1. Any segment that has the same p_offset and p_memsz as another segment, - and a null p_filesz, will be considered as having a p_filesz equal to the - other segment. This allow symbol's contents resolution to succeed even in - the presence of a bootstrapping copy mechanism from one segment to the - other. -*) -let relaxed = ref false - -exception Unknown_endianness - -(** Converts an elf endian into a bitstring endian *) -let elfdata_to_endian (e: elfdata): Bitstring.endian = - match e with - | ELFDATA2LSB -> Bitstring.LittleEndian - | ELFDATA2MSB -> Bitstring.BigEndian - | _ -> raise Unknown_endianness - -(** Parses an elf32 header *) -let read_elf32_ehdr (bs: bitstring): elf32_ehdr = - bitmatch bs with - | { e_ident : 16*8 : bitstring ; - rest : -1 : bitstring } -> - ( - bitmatch e_ident with - | { 0x7F : 8 ; - "ELF" : 24 : string ; - ei_class : 8 : int ; - ei_data : 8 : int ; - ei_version : 8 : int ; - padding : 72 : bitstring } -> - assert (is_zeros padding 72); - let ei_data = - begin match ei_data with - | 0 -> ELFDATANONE - | 1 -> ELFDATA2LSB - | 2 -> ELFDATA2MSB - | _ -> ELFDATAUNKNOWN - end - in - let e = elfdata_to_endian ei_data in - ( - bitmatch rest with - | { e_type : 16 : int, endian(e) ; - e_machine : 16 : int, endian(e) ; - e_version : 32 : int, endian(e) ; - e_entry : 32 : int, endian(e) ; - e_phoff : 32 : int, endian(e) ; - e_shoff : 32 : int, endian(e) ; - e_flags : 32 : bitstring ; - e_ehsize : 16 : int, endian(e) ; - e_phentsize : 16 : int, endian(e) ; - e_phnum : 16 : int, endian(e) ; - e_shentsize : 16 : int, endian(e) ; - e_shnum : 16 : int, endian(e) ; - e_shstrndx : 16 : int, endian(e) } -> - (* These shouldn't be different than this... *) - assert (e_ehsize = 52); - assert (e_phentsize = 32); - assert (e_shentsize = 40); - { - e_ident = - { - ei_class = - begin match ei_class with - | 0 -> ELFCLASSNONE - | 1 -> ELFCLASS32 - | 2 -> ELFCLASS64 - | _ -> ELFCLASSUNKNOWN - end; - ei_data = ei_data; - ei_version = - begin match ei_version with - | 0 -> EV_NONE - | 1 -> EV_CURRENT - | _ -> EV_UNKNOWN - end; - }; - e_type = - begin match e_type with - | 0 -> ET_NONE - | 1 -> ET_REL - | 2 -> ET_EXEC - | 3 -> ET_DYN - | 4 -> ET_CORE - | _ -> ET_UNKNOWN - end; - e_machine = - begin match e_machine with - | 0 -> EM_NONE - | 1 -> EM_M32 - | 2 -> EM_SPARC - | 3 -> EM_386 - | 4 -> EM_68K - | 5 -> EM_88K - | 7 -> EM_860 - | 8 -> EM_MIPS - | 10 -> EM_MIPS_RS4_BE - | 20 -> EM_PPC - | _ -> EM_UNKNOWN - end; - e_version = - begin match e_version with - | 0l -> EV_NONE - | 1l -> EV_CURRENT - | _ -> EV_UNKNOWN - end; - e_entry = e_entry; - e_phoff = e_phoff; - e_shoff = e_shoff; - e_flags = e_flags; - e_ehsize = e_ehsize; - e_phentsize = e_phentsize; - e_phnum = e_phnum; - e_shentsize = e_shentsize; - e_shnum = e_shnum; - e_shstrndx = e_shstrndx; - } - ) - ) - -(** Returns the file offset of the section header indexed *) -let section_header_offset (e_hdr: elf32_ehdr) (sndx: int): int = - Safe.(of_int32 e_hdr.e_shoff + (sndx * e_hdr.e_shentsize)) - -(** Returns the ndx-th string in the provided bitstring, according to null - characters *) -let strtab_string (bs: bitstring) (ndx: int): string = - let (str, ofs, _) = bs in - let start = (ofs / 8 + ndx) in - String.sub str start (String.index_from str start '\000' - start) - -(** Reads an ELF section header *) -let read_elf32_shdr (e_hdr: elf32_ehdr) (bs: bitstring) (strtab: bitstring) - (num: int): elf32_shdr = - let e = elfdata_to_endian e_hdr.e_ident.ei_data in - let bit_ofs = Safe.( - (section_header_offset e_hdr num) * 8 - ) in - bitmatch bs with - | { sh_name : 32 : endian(e), offset(bit_ofs) ; - sh_type : 32 : endian(e) ; - sh_flags : 32 : endian(e) ; - sh_addr : 32 : endian(e) ; - sh_offset : 32 : endian(e) ; - sh_size : 32 : endian(e) ; - sh_link : 32 : endian(e) ; - sh_info : 32 : endian(e) ; - sh_addralign : 32 : endian(e) ; - sh_entsize : 32 : endian(e) } -> - { - sh_name = strtab_string strtab (Safe32.to_int sh_name); - sh_type = - begin match sh_type with - | 0l -> SHT_NULL - | 1l -> SHT_PROGBITS - | 2l -> SHT_SYMTAB - | 3l -> SHT_STRTAB - | 4l -> SHT_RELA - | 5l -> SHT_HASH - | 6l -> SHT_DYNAMIC - | 7l -> SHT_NOTE - | 8l -> SHT_NOBITS - | 9l -> SHT_REL - | 10l -> SHT_SHLIB - | 11l -> SHT_DYNSYM - | _ -> SHT_UNKNOWN - end; - sh_flags = sh_flags ; - sh_addr = sh_addr ; - sh_offset = sh_offset ; - sh_size = sh_size ; - sh_link = sh_link ; - sh_info = sh_info ; - sh_addralign = sh_addralign ; - sh_entsize = sh_entsize ; - } - -(** Reads an elf program header *) -let read_elf32_phdr (e_hdr: elf32_ehdr) (bs: bitstring) (ndx: int): elf32_phdr = - let e = elfdata_to_endian e_hdr.e_ident.ei_data in - let bit_ofs = Safe.( - ((of_int32 e_hdr.e_phoff) + (ndx * e_hdr.e_phentsize)) * 8 - ) in - bitmatch bs with - | { p_type : 32 : endian(e), offset(bit_ofs) ; - p_offset : 32 : endian(e) ; - p_vaddr : 32 : endian(e) ; - p_paddr : 32 : endian(e) ; - p_filesz : 32 : endian(e) ; - p_memsz : 32 : endian(e) ; - p_flags : 32 : bitstring ; - p_align : 32 : endian(e) } -> - { - p_type = - begin match p_type with - | 0l -> PT_NULL - | 1l -> PT_LOAD - | 2l -> PT_DYNAMIC - | 3l -> PT_INTERP - | 4l -> PT_NOTE - | 5l -> PT_SHLIB - | 6l -> PT_PHDR - | _ -> PT_UNKNOWN - end; - p_offset = p_offset ; - p_vaddr = p_vaddr ; - p_paddr = p_paddr ; - p_filesz = p_filesz ; - p_memsz = p_memsz ; - p_flags = p_flags ; - p_align = p_align ; - } - -(** Reads an ELF symbol *) -let read_elf32_sym (e_hdr: elf32_ehdr) (symtab: bitstring) (strtab: bitstring) - (num: int): elf32_sym = - let e = elfdata_to_endian e_hdr.e_ident.ei_data in - let bit_ofs = Safe.(num * 128) in (* each symbol takes 16 bytes = 128 bits *) - bitmatch symtab with - | { st_name : 32 : endian(e), offset(bit_ofs) ; - st_value : 32 : endian(e) ; - st_size : 32 : endian(e) ; - st_bind : 4 ; - st_type : 4 ; - st_other : 8 ; - st_shndx : 16 : endian(e) } -> - { - st_name = strtab_string strtab (Safe32.to_int st_name) ; - st_value = st_value ; - st_size = st_size ; - st_bind = - begin match st_bind with - | 0 -> STB_LOCAL - | 1 -> STB_GLOBAL - | 2 -> STB_WEAK - | _ -> STB_UNKNOWN - end; - st_type = - begin match st_type with - | 0 -> STT_NOTYPE - | 1 -> STT_OBJECT - | 2 -> STT_FUNC - | 3 -> STT_SECTION - | 4 -> STT_FILE - | _ -> STT_UNKNOWN - end; - st_other = st_other ; - st_shndx = st_shndx ; - } - -(** Reads a whole ELF file from a bitstring *) -let read_elf_bs (bs: bitstring): elf = - let e_hdr = read_elf32_ehdr bs in - (* To initialize section names we need the string table *) - let strtab = ( - let e = elfdata_to_endian e_hdr.e_ident.ei_data in - let strtab_sndx = e_hdr.e_shstrndx in - let strtab_shofs = section_header_offset e_hdr strtab_sndx in - let skipped_bits = Safe.(strtab_shofs * 8 + 128) in - bitmatch bs with - | { ofs : 32 : endian(e), offset(skipped_bits) ; - size : 32 : endian(e) } -> - Bitstring.subbitstring bs Safe.(of_int32 ofs * 8) Safe.(of_int32 size * 8) - ) - in - let e_shdra = - Array.init e_hdr.e_shnum (read_elf32_shdr e_hdr bs strtab) - in - let symtab_sndx = section_ndx_by_name_noelf e_shdra ".symtab" in - let e_symtab = ( - let symtab_shdr = e_shdra.(symtab_sndx) in - let symtab_strtab_sndx = symtab_shdr.sh_link in - let symtab_nb_ent = (Safe32.to_int symtab_shdr.sh_size / 16) in - Array.init symtab_nb_ent - (read_elf32_sym e_hdr - (section_bitstring_noelf bs e_shdra symtab_sndx) - (section_bitstring_noelf bs e_shdra (Safe32.to_int symtab_strtab_sndx))) - ) in - let e_phdra = - let untweaked = Array.init e_hdr.e_phnum (read_elf32_phdr e_hdr bs) in - if !relaxed - then - Array.mapi - (fun ndx curr -> - if ndx < 1 - then curr - else - let prev = untweaked.(ndx - 1) in - if (curr.p_offset = prev.p_offset) - && (curr.p_memsz = prev.p_memsz) - then { curr with p_filesz = prev.p_filesz } - else curr - ) - untweaked - else untweaked - in - let e_sym_phdr = - let intervals = - Array.mapi - (fun ndx phdr -> (* (ndx, (start, stop), type) *) - (ndx, - (phdr.p_vaddr, Safe32.(phdr.p_vaddr + phdr.p_memsz - 1l)), - phdr.p_type - ) - ) - e_phdra - in - let intervals = Array.of_list ( - List.filter - (function (_, _, PT_LOAD) -> true | _ -> false) - (Array.to_list intervals) - ) in - Array.fast_sort (fun (_, (x, _), _) (_, (y, _), _) -> compare x y) intervals; - let lookup = - sorted_lookup - ( - fun (_, (a, b), _) v -> - if a <= v && v <= b - then 0 - else compare a v - ) - intervals - in - fun vaddr -> - begin match lookup vaddr with - | None -> None - | Some(ndx, (_, _), _) -> Some(ndx) - end - in - let e_syms_by_name = - let m = ref StringMap.empty in - for i = 0 to Array.length e_symtab - 1 do - let name = strip_versioning e_symtab.(i).st_name in - let list = try StringMap.find name !m with Not_found -> [] in - m := StringMap.add name (i :: list) !m - done; - !m - in - { - e_bitstring = bs; - e_hdr = e_hdr; - e_shdra = e_shdra; - e_phdra = e_phdra; - e_symtab = e_symtab; - e_symtab_sndx = symtab_sndx; - e_sym_phdr = e_sym_phdr; - e_syms_by_name = e_syms_by_name; - } - -(** Reads a whole ELF file from a file name *) -let read_elf (elffilename: string): elf = - let bs = Bitstring.bitstring_of_file elffilename in - read_elf_bs bs diff --git a/checklink/ELF_printers.ml b/checklink/ELF_printers.ml deleted file mode 100644 index 82ba479b..00000000 --- a/checklink/ELF_printers.ml +++ /dev/null @@ -1,206 +0,0 @@ -open ELF_types -open Library - -let string_of_elf32_half = string_of_int -let string_of_elf32_addr = string_of_int32 -let string_of_elf32_off = string_of_int32 -let string_of_elf32_word = string_of_int32 - -let string_of_elfclass = function -| ELFCLASSNONE -> "ELFCLASSNONE" -| ELFCLASS32 -> "ELFCLASS32" -| ELFCLASS64 -> "ELFCLASS64" -| ELFCLASSUNKNOWN -> "ELFCLASSUNKNOWN" - -let string_of_elfdata = function -| ELFDATANONE -> "ELFDATANONE" -| ELFDATA2LSB -> "ELFDATA2LSB" -| ELFDATA2MSB -> "ELFDATA2MSB" -| ELFDATAUNKNOWN -> "ELFDATAUNKNOWN" - -let string_of_ev = function -| EV_NONE -> "EV_NONE" -| EV_CURRENT -> "EV_CURRENT" -| EV_UNKNOWN -> "EV_UNKNOWN" - -let string_of_elf_identification ei = - Printf.sprintf - "{ -ei_class = %s; -ei_data = %s; -ei_version = %s; -}" - (string_of_elfclass ei.ei_class ) - (string_of_elfdata ei.ei_data ) - (string_of_ev ei.ei_version) - -let string_of_et = function -| ET_NONE -> "ET_NONE" -| ET_REL -> "ET_REL" -| ET_EXEC -> "ET_EXEC" -| ET_DYN -> "ET_DYN" -| ET_CORE -> "ET_CORE" -| ET_UNKNOWN -> "ET_UNKNOWN" - -let string_of_em = function -| EM_NONE -> "EM_NONE" -| EM_M32 -> "EM_M32" -| EM_SPARC -> "EM_SPARC" -| EM_386 -> "EM_386" -| EM_68K -> "EM_68K" -| EM_88K -> "EM_88K" -| EM_860 -> "EM_860" -| EM_MIPS -> "EM_MIPS" -| EM_MIPS_RS4_BE -> "EM_MIPS_RS4_BE" -| EM_PPC -> "EM_PPC" -| EM_UNKNOWN -> "EM_UNKNOWN" - -let string_of_elf32_ehdr eh = - Printf.sprintf - "{ -e_ident = %s; -e_type = %s; -e_machine = %s; -e_version = %s; -e_entry = %s; -e_phoff = %s; -e_shoff = %s; -e_flags = %s; -e_ehsize = %s; -e_phentsize = %s; -e_phnum = %s; -e_shentsize = %s; -e_shnum = %s; -e_shstrndx = %s; -}" - (string_of_elf_identification eh.e_ident ) - (string_of_et eh.e_type ) - (string_of_em eh.e_machine ) - (string_of_ev eh.e_version ) - (string_of_elf32_addr eh.e_entry ) - (string_of_elf32_off eh.e_phoff ) - (string_of_elf32_off eh.e_shoff ) - (string_of_bitstring eh.e_flags ) - (string_of_elf32_half eh.e_ehsize ) - (string_of_elf32_half eh.e_phentsize) - (string_of_elf32_half eh.e_phnum ) - (string_of_elf32_half eh.e_shentsize) - (string_of_elf32_half eh.e_shnum ) - (string_of_elf32_half eh.e_shstrndx ) - -let string_of_sht = function -| SHT_NULL -> "SHT_NULL" -| SHT_PROGBITS -> "SHT_PROGBITS" -| SHT_SYMTAB -> "SHT_SYMTAB" -| SHT_STRTAB -> "SHT_STRTAB" -| SHT_RELA -> "SHT_RELA" -| SHT_HASH -> "SHT_HASH" -| SHT_DYNAMIC -> "SHT_DYNAMIC" -| SHT_NOTE -> "SHT_NOTE" -| SHT_NOBITS -> "SHT_NOBITS" -| SHT_REL -> "SHT_REL" -| SHT_SHLIB -> "SHT_SHLIB" -| SHT_DYNSYM -> "SHT_DYNSYM" -| SHT_UNKNOWN -> "SHT_UNKNOWN" - -let string_of_elf32_shdr sh = - Printf.sprintf - "{ -sh_name = %s; -sh_type = %s; -sh_flags = %s; -sh_addr = %s; -sh_offset = %s; -sh_size = %s; -sh_link = %s; -sh_info = %s; -sh_addralign = %s; -sh_entsize = %s; -}" - (sh.sh_name ) - (string_of_sht sh.sh_type ) - (string_of_elf32_word sh.sh_flags ) - (string_of_elf32_addr sh.sh_addr ) - (string_of_elf32_off sh.sh_offset ) - (string_of_elf32_word sh.sh_size ) - (string_of_elf32_word sh.sh_link ) - (string_of_elf32_word sh.sh_info ) - (string_of_elf32_word sh.sh_addralign) - (string_of_elf32_word sh.sh_entsize ) - -let string_of_p_type = function -| PT_NULL -> "PT_NULL" -| PT_LOAD -> "PT_LOAD" -| PT_DYNAMIC -> "PT_DYNAMIC" -| PT_INTERP -> "PT_INTERP" -| PT_NOTE -> "PT_NOTE" -| PT_SHLIB -> "PT_SHLIB" -| PT_PHDR -> "PT_PHDR" -| PT_UNKNOWN -> "PT_UNKNOWN" - -let string_of_elf32_phdr ph = - Printf.sprintf - "{ -p_type = %s; -p_offset = %s; -p_vaddr = %s; -p_paddr = %s; -p_filesz = %s; -p_memsz = %s; -p_flags = %s; -p_align = %s; -}" - (string_of_p_type ph.p_type ) - (string_of_elf32_off ph.p_offset) - (string_of_elf32_addr ph.p_vaddr ) - (string_of_elf32_addr ph.p_paddr ) - (string_of_elf32_word ph.p_filesz) - (string_of_elf32_word ph.p_memsz ) - (string_of_bitstring ph.p_flags ) - (string_of_elf32_word ph.p_align ) - -let string_of_elf32_st_bind = function -| STB_LOCAL -> "STB_LOCAL" -| STB_GLOBAL -> "STB_GLOBAL" -| STB_WEAK -> "STB_WEAK" -| STB_UNKNOWN -> "STB_UNKNOWN" - -let string_of_elf32_st_type = function -| STT_NOTYPE -> "STT_NOTYPE" -| STT_OBJECT -> "STT_OBJECT" -| STT_FUNC -> "STT_FUNC" -| STT_SECTION -> "STT_SECTION" -| STT_FILE -> "STT_FILE" -| STT_UNKNOWN -> "STT_UNKNOWN" - -let string_of_elf32_sym s = - Printf.sprintf - "{ -st_name = %s; -st_value = %s; -st_size = %s; -st_bind = %s; -st_type = %s; -st_other = %s; -st_shndx = %s; -}" - (s.st_name ) - (string_of_elf32_addr s.st_value) - (string_of_elf32_word s.st_size ) - (string_of_elf32_st_bind s.st_bind ) - (string_of_elf32_st_type s.st_type ) - (string_of_int s.st_other) - (string_of_elf32_half s.st_shndx) - -let string_of_elf e = - Printf.sprintf - "{ -e_header = %s; -e_sections = %s; -e_programs = %s; -e_symtab = %s; -}" - (string_of_elf32_ehdr e.e_hdr ) - (string_of_array string_of_elf32_shdr ",\n" e.e_shdra) - (string_of_array string_of_elf32_phdr ",\n" e.e_phdra) - (string_of_array string_of_elf32_sym ",\n" e.e_symtab) diff --git a/checklink/ELF_types.ml b/checklink/ELF_types.ml deleted file mode 100644 index f67b91d1..00000000 --- a/checklink/ELF_types.ml +++ /dev/null @@ -1,170 +0,0 @@ -open Library - -type elf32_addr = int32 -type elf32_half = int -type elf32_off = int32 -type elf32_sword = int32 -type elf32_word = int32 -type byte = int - -(** ELF identification *) - -type elfclass = - | ELFCLASSNONE - | ELFCLASS32 - | ELFCLASS64 - | ELFCLASSUNKNOWN - -type elfdata = - | ELFDATANONE - | ELFDATA2LSB - | ELFDATA2MSB - | ELFDATAUNKNOWN - -type ev = - | EV_NONE - | EV_CURRENT - | EV_UNKNOWN - -type elf_identification = - { ei_class : elfclass (* 32/64 bit *) - ; ei_data : elfdata (* endianness *) - ; ei_version : ev (* ELF header version *) - } - -(** ELF header *) - -type et = - | ET_NONE - | ET_REL - | ET_EXEC - | ET_DYN - | ET_CORE - | ET_UNKNOWN - -type em = - | EM_NONE - | EM_M32 - | EM_SPARC - | EM_386 - | EM_68K - | EM_88K - | EM_860 - | EM_MIPS - | EM_MIPS_RS4_BE - | EM_PPC - | EM_UNKNOWN - -let shn_UNDEF = 0 -let shn_ABS = 0xFFF1 -let shn_COMMON = 0xFFF2 - -type elf32_ehdr = - { e_ident : elf_identification (* Machine-independent data *) - ; e_type : et (* Object file type *) - ; e_machine : em (* Required architecture *) - ; e_version : ev (* Object file version *) - ; e_entry : elf32_addr (* Entry point virtual address *) - ; e_phoff : elf32_off (* Program header table's offset *) - ; e_shoff : elf32_off (* Section header table's offset *) - ; e_flags : Bitstring.bitstring (* Processor-specific flags *) - ; e_ehsize : elf32_half (* ELF header size *) - ; e_phentsize : elf32_half (* Size of a program header's entry *) - ; e_phnum : elf32_half (* Number of program header entries *) - ; e_shentsize : elf32_half (* Size of a section header's entry *) - ; e_shnum : elf32_half (* Number of section header entries *) - ; e_shstrndx : elf32_half (* Section name string table index *) - } - -(** ELF section header *) - -type sht = - | SHT_NULL - | SHT_PROGBITS - | SHT_SYMTAB - | SHT_STRTAB - | SHT_RELA - | SHT_HASH - | SHT_DYNAMIC - | SHT_NOTE - | SHT_NOBITS - | SHT_REL - | SHT_SHLIB - | SHT_DYNSYM - | SHT_UNKNOWN - -type elf32_shdr = - { sh_name : string - ; sh_type : sht - ; sh_flags : elf32_word - ; sh_addr : elf32_addr - ; sh_offset : elf32_off - ; sh_size : elf32_word - ; sh_link : elf32_word - ; sh_info : elf32_word - ; sh_addralign : elf32_word - ; sh_entsize : elf32_word - } - -let shf_WRITE = 0x1l -let shf_ALLOC = 0x2l -let shf_EXECINSTR = 0x4l - -type elf32_st_bind = - | STB_LOCAL - | STB_GLOBAL - | STB_WEAK - | STB_UNKNOWN - -type elf32_st_type = - | STT_NOTYPE - | STT_OBJECT - | STT_FUNC - | STT_SECTION - | STT_FILE - | STT_UNKNOWN - -type elf32_sym = - { st_name : string - ; st_value : elf32_addr - ; st_size : elf32_word - ; st_bind : elf32_st_bind - ; st_type : elf32_st_type - ; st_other : byte - ; st_shndx : elf32_half - } - -(** ELF program header *) - -type p_type = - | PT_NULL - | PT_LOAD - | PT_DYNAMIC - | PT_INTERP - | PT_NOTE - | PT_SHLIB - | PT_PHDR - | PT_UNKNOWN - -type elf32_phdr = - { p_type : p_type - ; p_offset : elf32_off - ; p_vaddr : elf32_addr - ; p_paddr : elf32_addr - ; p_filesz : elf32_word - ; p_memsz : elf32_word - ; p_flags : bitstring - ; p_align : elf32_word - } - -(** ELF *) -type elf = - { e_bitstring : bitstring - ; e_hdr : elf32_ehdr - ; e_shdra : elf32_shdr array - ; e_phdra : elf32_phdr array - ; e_symtab : elf32_sym array - ; e_symtab_sndx : int (* section index of the symbol table *) - ; e_sym_phdr : int32 -> int option (* fast sym -> phdr lookup *) - ; e_syms_by_name : int list StringMap.t (* fast name -> sym lookup *) - } diff --git a/checklink/ELF_utils.ml b/checklink/ELF_utils.ml deleted file mode 100644 index 898c778d..00000000 --- a/checklink/ELF_utils.ml +++ /dev/null @@ -1,128 +0,0 @@ -open ELF_types -open Library - -let section_ndx_by_name_noelf (eshdra: elf32_shdr array)(name: string): int = - match array_exists (fun eshdr -> eshdr.sh_name = name) eshdra with - | Some sndx -> sndx - | None -> assert false - -let section_ndx_by_name (e: elf)(name: string): int option = - array_exists (fun eshdr -> eshdr.sh_name = name) e.e_shdra - -let section_bitstring_noelf - (bs: bitstring)(eshdra: elf32_shdr array)(sndx: int): bitstring = - let sofs = Safe32.to_int eshdra.(sndx).sh_offset in - let size = Safe32.to_int eshdra.(sndx).sh_size in - Bitstring.subbitstring bs Safe.(sofs * 8) Safe.(size * 8) - -let section_bitstring (e: elf): int -> bitstring = - section_bitstring_noelf e.e_bitstring e.e_shdra - -let physical_offset_of_vaddr (e: elf)(vaddr: int32): int32 option = - begin match e.e_sym_phdr vaddr with - | None -> None - | Some(pndx) -> - let phdr = e.e_phdra.(pndx) in - let vaddr_ofs = Safe32.(vaddr - phdr.p_vaddr) in - Some(Safe32.(phdr.p_offset + vaddr_ofs)) - end - -(* TODO: could make this more efficient, but it's not often called *) -let section_at_vaddr (e: elf)(vaddr: int32): int option = - array_exists - (fun shdr -> - shdr.sh_addr <= vaddr && vaddr < Int32.add shdr.sh_addr shdr.sh_size - ) - e.e_shdra - -(** - Returns the bitstring of the specified byte size beginning at the specified - virtual address, along with its physical byte offset and physical byte size, - that is, the space it occupies in the file. -*) -let bitstring_at_vaddr (e: elf)(vaddr: int32)(size:int32): - (bitstring * int32 * int32) option = - match e.e_sym_phdr vaddr with - | None -> None - | Some(pndx) -> - let phdr = e.e_phdra.(pndx) in - let phdr_mem_first = phdr.p_vaddr in - let phdr_mem_last = Safe32.(phdr.p_vaddr + phdr.p_memsz - 1l) in - let vaddr_mem_first = vaddr in - let vaddr_mem_last = Safe32.(vaddr + size - 1l) in - if not (phdr_mem_first <= vaddr_mem_first && vaddr_mem_last <= phdr_mem_last) - then None (* we're overlapping segments *) - else - let vaddr_relative_ofs = Safe32.(vaddr_mem_first - phdr_mem_first) in - let vaddr_file_ofs = Safe32.(phdr.p_offset + vaddr_relative_ofs) in - if phdr.p_filesz = 0l || vaddr_relative_ofs > phdr.p_filesz - then - Some( - Bitstring.create_bitstring Safe32.(to_int (8l * size)), - phdr.p_offset, (* whatever? *) - 0l - ) - else if Safe32.(vaddr_relative_ofs + size) > phdr.p_filesz - then - let bit_start = Safe32.(to_int (8l * vaddr_file_ofs)) in - let vaddr_file_len = Safe32.(phdr.p_filesz - vaddr_relative_ofs) in - let bit_len = Safe32.(to_int (8l * vaddr_file_len)) in - let first = Bitstring.subbitstring e.e_bitstring bit_start bit_len in - let rest = Bitstring.create_bitstring (8 * Safe32.to_int size - bit_len) in - Some( - Bitstring.concat [first; rest], - vaddr_file_ofs, - vaddr_file_len - ) - else - let bit_start = Safe32.(to_int (8l * (phdr.p_offset + vaddr_relative_ofs))) in - let bit_len = Safe.(8 * Safe32.to_int size) in - Some( - Bitstring.subbitstring e.e_bitstring bit_start bit_len, - vaddr_file_ofs, - size - ) - -(** - Returns the entire bitstring that begins at the specified virtual address and - ends at the end of the segment. -*) -let bitstring_at_vaddr_nosize (e: elf)(vaddr: int32): - (bitstring * int32 * int32) option = - match e.e_sym_phdr vaddr with - | None -> None - | Some(pndx) -> - let phdr = e.e_phdra.(pndx) in - let first_byte_vaddr = vaddr in - let last_byte_vaddr = Safe32.(phdr.p_vaddr + phdr.p_memsz - 1l) in - let size = Safe32.(last_byte_vaddr - first_byte_vaddr + 1l) in - bitstring_at_vaddr e vaddr size - -(** - Removes symbol version for GCC's symbols. -*) -let strip_versioning (s: string): string = - try String.sub s 0 (String.index s '@') - with Not_found -> s - -(** - Removes CompCert's mangling of variadic functions -*) -let strip_mangling (s: string): string = - try String.sub s 0 (String.index s '$') - with Not_found -> s - -(** - Returns the list of all symbols matching the specified name. -*) -let ndxes_of_sym_name (e: elf) (name: string): int list = - try StringMap.find (strip_mangling name) e.e_syms_by_name with Not_found -> [] - -(** - Returns the index of the first symbol matching the specified name, if it - exists. -*) -let ndx_of_sym_name (e: elf) (name: string): int option = - match ndxes_of_sym_name e name with - | [] -> None - | h::_ -> Some(h) diff --git a/checklink/Exc.ml b/checklink/Exc.ml deleted file mode 100644 index 101087d2..00000000 --- a/checklink/Exc.ml +++ /dev/null @@ -1,2 +0,0 @@ -exception IntOverflow -exception Int32Overflow diff --git a/checklink/Frameworks.ml b/checklink/Frameworks.ml deleted file mode 100644 index 30c0b381..00000000 --- a/checklink/Frameworks.ml +++ /dev/null @@ -1,214 +0,0 @@ -open Camlcoq -open Asm -open AST -open ELF_types -open Lens -open Library - -type log_entry = - | DEBUG of string - | ERROR of string - | INFO of string - | WARNING of string - -type byte_chunk_desc = - | ELF_header - | ELF_progtab - | ELF_shtab - | ELF_section_strtab - | ELF_symbol_strtab - | Symtab_data of elf32_sym - | Symtab_function of elf32_sym - | Data_symbol of elf32_sym - | Function_symbol of elf32_sym - | Zero_symbol - | Stub of string - | Jumptable - | Float_literal of int64 - | Float32_literal of int32 - | Padding - | Unknown of string - -(* This type specifies whether its argument was inferred by the tool or provided - via a config file. *) -type 'a inferrable = - | Inferred of 'a - | Provided of 'a - -let from_inferrable = function -| Inferred(x) -> x -| Provided(x) -> x - -(** This framework is carried along while analyzing the whole ELF file. -*) -type e_framework = { - elf: elf; - log: log_entry list; - (** Every time a chunk of the ELF file is checked, it is added to this list. - The first two fields are the start and stop offsets, the third is an - alignment constraint, the last is a description. *) - chkd_bytes_list: (int32 * int32 * int * byte_chunk_desc) list; - chkd_fun_syms: bool array; - chkd_data_syms: bool array; - (** The mapping from CompCert sections to ELF sections will be inferred along - the way. This way, we can check things without prior knowledge of the - linker script. The set holds conflicts for the mapping, if more than one - mapping is inferred. These are reported once, at the end. *) - section_map: (string inferrable * StringSet.t) StringMap.t; - (** We will assign a virtual address to each register that can act as an SDA - base register. *) - sda_map: (int32 inferrable) IntMap.t; - (** Contains the symbols that we expect to be missing from the .sdump files *) - missing_syms: StringSet.t; -} - -module PosOT = struct - type t = P.t - let compare = Pervasives.compare -end - -module PosMap = Map.Make(PosOT) - -(** This framework is carried along while analyzing one .sdump file, which - may contain multiple functions. *) -type s_framework = { - ef: e_framework; - program: Asm.program; - (** Maps every CompCert ident to a string. This will not be the exact name of - the symbol in the ELF file though: CompCert does some mangling for - variadic functions, and some linkers do some versioning in their symbols. - *) - ident_to_name: (ident, string) Hashtbl.t; - (** Maps a CompCert ident to a list of candidates symbol indices. We can only - try to match symbols by name until we begin the analysis, so multiple - static symbols might match a given name. The list will be narrowed down - as we learn more about the contents of the symbol. - *) - ident_to_sym_ndx: (int list) PosMap.t; - (** This structure is imported from CompCert's .sdump, and describes each - atom. *) - atoms: (ident, C2C.atom_info) Hashtbl.t; -} - -(** This framework is carried while analyzing a single function. *) -type f_framework = { - sf: s_framework; - (** The symbol index of the current function. *) - this_sym_ndx: int; - (** The CompCert ident of the current function. *) - this_ident: ident; - (** A mapping from local labels to virtual addresses. *) - label_to_vaddr: int32 PosMap.t; - (** A list of all the labels encountered while processing the body. *) - label_list: label list; -} - -(** A few lenses that prove useful for manipulating frameworks. -*) - -let sf_ef: (s_framework, e_framework) Lens.t = { - get = (fun sf -> sf.ef); - set = (fun ef sf -> { sf with ef = ef }); -} - -let ff_sf: (f_framework, s_framework) Lens.t = { - get = (fun ff -> ff.sf); - set = (fun sf ff -> { ff with sf = sf }); -} - -let ff_ef = ff_sf |-- sf_ef - -let log = { - get = (fun ef -> ef.log); - set = (fun l ef -> { ef with log = l }); -} - -let section_map = { - get = (fun ef -> ef.section_map); - set = (fun m ef -> { ef with section_map = m }); -} - -let sda_map = { - get = (fun ef -> ef.sda_map); - set = (fun m ef -> { ef with sda_map = m }); -} - -let ident_to_sym_ndx = { - get = (fun sf -> sf.ident_to_sym_ndx); - set = (fun i sf -> { sf with ident_to_sym_ndx = i }); -} - -(** Adds a range to the checked bytes list. -*) -let add_range (start: int32) (length: int32) (align: int) (bcd: byte_chunk_desc) - (efw: e_framework): e_framework = - assert (0l <= start && 0l < length); - let stop = Safe32.(start + length - 1l) in - { - efw with - chkd_bytes_list = - (* Float constants can appear several times in the code, we don't - want to add them multiple times *) - if (List.exists - (fun (a, b, _, _) -> a = start && b = stop) - efw.chkd_bytes_list) - then efw.chkd_bytes_list - else (start, stop, align, bcd) :: efw.chkd_bytes_list; - } - -(** Some useful combinators to make it all work. -*) - -(* external ( >>> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" *) -let ( >>> ) (a: 'a) (f: 'a -> 'b): 'b = f a - -let ( >>^ ) (a: 'a or_err) (f: 'a -> 'b): 'b or_err = - match a with - | ERR(s) -> ERR(s) - | OK(x) -> OK(f x) - -let ( >>= ) (a: 'a or_err) (f: 'a -> 'b or_err): 'b or_err = - match a with - | ERR(s) -> ERR(s) - | OK(x) -> f x - -let ( ^%=? ) (lens: ('a, 'b) Lens.t) (transf: 'b -> 'b or_err) - (arg: 'a): 'a or_err = - let focus = arg |. lens in - match transf focus with - | OK(res) -> OK((lens ^= res) arg) - | ERR(s) -> ERR(s) - -(** Finally, some printers. -*) - -let format_logtype = Printf.sprintf "%10s" - -let string_of_log_entry show_debug entry = - match entry with - | DEBUG(s) -> if show_debug then (format_logtype "DEBUG: ") ^ s else "" - | ERROR(s) -> (format_logtype "ERROR: ") ^ s - | INFO(s) -> (format_logtype "INFO: ") ^ s - | WARNING(s) -> (format_logtype "WARNING: ") ^ s - -let fatal s = failwith ((format_logtype "FATAL: ") ^ s) - -let verbose_elfmap = ref false - -let string_of_byte_chunk_desc = function -| ELF_header -> "ELF header" -| ELF_progtab -> "ELF program header table" -| ELF_shtab -> "ELF section header table" -| ELF_section_strtab -> "ELF section string table" -| ELF_symbol_strtab -> "ELF symbol string table" -| Symtab_data(s) -> "Data symbol table entry: " ^ s.st_name -| Symtab_function(s) -> "Function symbol table entry: " ^ s.st_name -| Data_symbol(s) -> "Data symbol: " ^ s.st_name -| Function_symbol(s) -> "Function symbol: " ^ s.st_name -| Zero_symbol -> "Symbol 0" -| Stub(s) -> "Stub for: " ^ s -| Jumptable -> "Jump table" -| Float_literal(f) -> "Float literal: " ^ string_of_int64 f -| Float32_literal(f) -> "Float32 literal: " ^ string_of_int32 f -| Padding -> "Padding" -| Unknown(s) -> "???" ^ (if !verbose_elfmap then s else "") diff --git a/checklink/Fuzz.ml b/checklink/Fuzz.ml deleted file mode 100644 index 0d091c18..00000000 --- a/checklink/Fuzz.ml +++ /dev/null @@ -1,175 +0,0 @@ -open Check -open ELF_parsers -open ELF_types -open Frameworks -open Library - -let fuzz_debug = ref false - -let string_of_byte = Printf.sprintf "0x%02x" - -let full_range_of_byte elfmap byte = - let byte = Int32.of_int byte in - List.find (fun (a, b, _, _) -> a <= byte && byte <= b) elfmap - -let range_of_byte elfmap byte = - let (_, _, _, r) = full_range_of_byte elfmap byte in - r - -(** [fuzz_check] will print what happened on stderr, and report errors (that is, - when the check went fine) to stdout. -*) -let fuzz_check elfmap bs byte old sdumps = - let is_error = function ERROR(_) -> true | _ -> false in - let (str, _, _) = bs in - let fuzz_description = - string_of_int32 (Int32.of_int byte) ^ " <- " ^ - string_of_byte (Char.code str.[byte]) ^ " (was " ^ - string_of_byte (Char.code old) ^ ") - " ^ - string_of_byte_chunk_desc (range_of_byte elfmap byte) - in - if !fuzz_debug - then print_endline fuzz_description; - try - (* The point here is to go all the way through the checks, and see whether - the checker returns an ERROR or raises an exception. If not, then we - might be missing a bug! - *) - let elf = read_elf_bs bs in - let efw = check_elf_nodump elf sdumps in - if List.exists is_error efw.log - then (* finding an ERROR is the expected behavior *) - begin - if !fuzz_debug - then print_endline ( - string_of_log_entry false (List.find is_error efw.log) - ) - end - else (* not finding an ERROR is bad thus reported *) - print_endline (fuzz_description ^ " DID NOT CAUSE AN ERROR!") - with - | Assert_failure(s, l, c) -> - if !fuzz_debug - then Printf.printf "fuzz_check failed an assertion at %s (%d, %d)\n" s l c - | Exc.IntOverflow | Exc.Int32Overflow -> - if !fuzz_debug - then Printf.printf "fuzz_check raised an integer overflow exception\n" - | Match_failure(s, l, c) -> - if !fuzz_debug - then Printf.printf "fuzz_check raised a match failure at %s (%d, %d)\n" s l c - | Not_found -> - if !fuzz_debug - then Printf.printf "fuzz_check raised a not found exception\n" - | Invalid_argument(s) -> - if !fuzz_debug - then Printf.printf "fuzz_check raised an invalid argument: %s\n" s - | ELF_parsers.Unknown_endianness -> - if !fuzz_debug - then Printf.printf "fuzz_check raised an unknown endianness exception\n" - -(** Tries to prevent some easy-to-catch false positives. Some known false - positives are however hard to predict. For instance, when the virtual - address of a stub is replaced by the virtual address of another exact - same stub. -*) -let ok_fuzz elfmap str byte fuzz = - let (a, b, _, r) = full_range_of_byte elfmap byte in - let a = Safe32.to_int a in - let old = Char.code str.[byte] in - let fuz = Char.code fuzz in - match r with - | ELF_header -> - not (List.mem byte - [ - 0x18; 0x19; 0x1a; 0x1b; (* e_entry *) - 0x1c; 0x1d; 0x1e; 0x1f; (* e_phoff *) - 0x24; 0x25; 0x26; 0x27; (* e_flags *) - 0x2c; 0x2d (* e_phnum *) - ] - ) - | ELF_progtab -> false - | ELF_shtab -> false - | ELF_section_strtab -> false - | ELF_symbol_strtab -> false - | Symtab_data(_) -> - (* False positive: switching from/to STT_NOTYPE *) - not (byte = a + 12 - && ((old land 0xf = 0) || (fuz land 0xf = 0)) - ) - | Symtab_function(_) -> true - | Data_symbol(_) -> true - | Function_symbol(_) -> - let opcode = Char.code str.[byte - 3] in - (* False positive: rlwinm with bitmask 0 31 = bitmask n (n - 1) *) - not (0x54 <= opcode && opcode <= 0x57 && old = 0x3E - && (fuz = 0x40 || fuz = 0x82 || fuz = 0xc4)) - | Zero_symbol -> false - | Stub(_) -> true - | Jumptable -> true - | Float_literal(_) -> true - | Float32_literal(_) -> true - (* padding is allowed to be non-null, but won't be recognized as padding, but - as unknown, which is not an ERROR *) - | Padding -> false - | Unknown(_) -> false - -let fuzz_byte str byte_ndx = - let rand = Char.chr (Random.int 255) in (* [0 - 254] *) - if rand = str.[byte_ndx] (* if we picked a byte equal to the current *) - then Char.chr 255 (* then replace with byte 255 *) - else rand (* else replace with the byte we picked *) - -let rec find_byte_to_fuzz elfmap str byterange = - let byte = Random.int byterange in - let fuzz = fuzz_byte str byte in - if ok_fuzz elfmap str byte fuzz - then (byte, fuzz) - else find_byte_to_fuzz elfmap str byterange - -let get_elfmap elffilename = - let ic = open_in (elffilename ^ ".elfmap") in - let elfmap = input_value ic in - close_in ic; - elfmap - -(** Randomly fuzz bytes forever *) -let fuzz_loop elffilename sdumps = - let elfmap = get_elfmap elffilename in - let (str, ofs, len) = Bitstring.bitstring_of_file elffilename in - let rec fuzz_loop_aux () = - let (byte, fuzz) = find_byte_to_fuzz elfmap str (len/8) in - let str' = String.copy str in - str'.[byte] <- fuzz; - fuzz_check elfmap (str', ofs, len) byte str.[byte] sdumps; - fuzz_loop_aux () - in fuzz_loop_aux () - -let rec fuzz_every_byte_once_aux elfmap bs sdumps (current: int): unit = - let (str, ofs, len) = bs in - if current = len / 8 (* len is in bits *) - then () - else ( - let fuzz = fuzz_byte str current in - if ok_fuzz elfmap str current fuzz - then ( - let str' = String.copy str in - str'.[current] <- fuzz; - fuzz_check elfmap (str', ofs, len) current str.[current] sdumps - ); - fuzz_every_byte_once_aux elfmap bs sdumps (current + 1) - ) - -(** Fuzz each byte of the file once with a random new value *) -let fuzz_every_byte_once elffilename sdumps = - let elfmap = get_elfmap elffilename in - let bs = Bitstring.bitstring_of_file elffilename in - fuzz_every_byte_once_aux elfmap bs sdumps 0 - -(** Fuzz each byte of the file, then loop *) -let fuzz_every_byte_loop elffilename sdumps = - let elfmap = get_elfmap elffilename in - let bs = Bitstring.bitstring_of_file elffilename in - let rec fuzz_every_byte_loop_aux () = - fuzz_every_byte_once_aux elfmap bs sdumps 0; - fuzz_every_byte_loop_aux () - in fuzz_every_byte_loop_aux () diff --git a/checklink/Lens.ml b/checklink/Lens.ml deleted file mode 100644 index 43359334..00000000 --- a/checklink/Lens.ml +++ /dev/null @@ -1,32 +0,0 @@ -type ('a, 'b) t = { - get: 'a -> 'b; - set: 'b -> 'a -> 'a; -} - -let ( |- ) f g x = g (f x) - -let modify l f a = - let oldval = l.get a in - let newval = f oldval in - l.set newval a - -let compose l1 l2 = { - get = l2.get |- l1.get; - set = l1.set |- modify l2 -} - -let _get a l = l.get a - -let _set v a l = l.set v a - -let _modify f l = modify l f - -let (|.) = _get - -let (^=) l v = fun a -> _set v a l - -let (^%=) l f = _modify f l - -let (|--) l1 l2 = compose l2 l1 - -let (--|) = compose diff --git a/checklink/Library.ml b/checklink/Library.ml deleted file mode 100644 index 54bca411..00000000 --- a/checklink/Library.ml +++ /dev/null @@ -1,171 +0,0 @@ -open Camlcoq - -type bitstring = Bitstring.bitstring - -module IntMap = Map.Make(struct type t = int let compare = compare end) -module StringMap = Map.Make (String) -module StringSet = Set.Make (String) - -let is_some: 'a option -> bool = function -| Some(_) -> true -| None -> false - -let from_some: 'a option -> 'a = function -| Some(x) -> x -| None -> raise Not_found - -let filter_some (l: 'a option list): 'a list = - List.(map from_some (filter is_some l)) - -type 'a or_err = - | OK of 'a - | ERR of string - -let is_ok: 'a or_err -> bool = function -| OK(_) -> true -| ERR(_) -> false - -let is_err x = not (is_ok x) - -let from_ok: 'a or_err -> 'a = function -| OK(x) -> x -| ERR(_) -> assert false - -let from_err: 'a or_err -> string = function -| OK(_) -> assert false -| ERR(s) -> s - -let filter_ok (l: 'a or_err list): 'a list = - List.(map from_ok (filter is_ok l)) - -let filter_err (l: 'a or_err list): string list = - List.(map from_err (filter is_err l)) - -external id : 'a -> 'a = "%identity" - -(** [a; a + 1; ... ; b - 1; b] *) -let list_ab (a: int) (b: int): int list = - let rec list_ab_aux a b res = - if b < a - then res - else list_ab_aux a (b - 1) (b :: res) - in list_ab_aux a b [] - -(** [0; 1; ...; n - 1] *) -let list_n (n: int): int list = - list_ab 0 (n - 1) - -(** Checks for existence of an array element satisfying a condition, and returns - its index if it exists. -*) -let array_exists (cond: 'a -> bool) (arr: 'a array): int option = - let rec array_exists_aux ndx = - if ndx < 0 - then None - else if cond arr.(ndx) - then Some ndx - else array_exists_aux (ndx - 1) - in array_exists_aux (Array.length arr - 1) - -exception IntOverflow -exception Int32Overflow - -(* Can only return positive numbers 0 <= res < 2^31 *) -let positive_int32 p = - let rec positive_int32_unsafe = function - | P.Coq_xI(p) -> Int32.(add (shift_left (positive_int32_unsafe p) 1) 1l) - | P.Coq_xO(p) -> Int32.(shift_left (positive_int32_unsafe p) 1) - | P.Coq_xH -> 1l - in - let res = positive_int32_unsafe p in - if res >= 0l - then res - else raise IntOverflow - -(* This allows for 1 bit of overflow, effectively returning a negative *) -let rec positive_int32_lax = function -| P.Coq_xI(p) -> - let acc = positive_int32_lax p in - if acc < 0l - then raise Int32Overflow - else Int32.(add (shift_left acc 1) 1l) -| P.Coq_xO(p) -> - let acc = positive_int32_lax p in - if acc < 0l - then raise Int32Overflow - else Int32.shift_left acc 1 -| P.Coq_xH -> 1l - -let z_int32 = function -| Z.Z0 -> 0l -| Z.Zpos(p) -> positive_int32 p -| Z.Zneg(p) -> Int32.neg (positive_int32 p) - -let z_int32_lax = function -| Z.Z0 -> 0l -| Z.Zpos(p) -> positive_int32_lax p -| Z.Zneg(_) -> raise Int32Overflow - -let z_int z = Safe32.to_int (z_int32 z) - -let z_int_lax z = Safe32.to_int (z_int32_lax z) - -let z_int64 = Camlcoq.Z.to_int64 - -(* Some more printers *) - -let string_of_ffloat f = string_of_float (camlfloat_of_coqfloat f) -let string_of_ffloat32 f = string_of_float (camlfloat_of_coqfloat32 f) - -let string_of_array string_of_elt sep a = - let b = Buffer.create 1024 in - Buffer.add_string b "[\n"; - Array.iteri - (fun ndx elt -> - if ndx > 0 then Buffer.add_string b sep; - Buffer.add_string b (string_of_int ndx); - Buffer.add_string b ": "; - Buffer.add_string b (string_of_elt elt) - ) a; - Buffer.add_string b "\n]"; - Buffer.contents b - -let string_of_list string_of_elt sep l = - String.concat sep (List.map string_of_elt l) - -let string_of_bitstring bs = - let rec string_of_bitset_aux bs = - bitmatch bs with - | { bit : 1 : int ; - rest : -1 : bitstring } -> - (if bit then "1" else "0") ^ (string_of_bitset_aux rest) - | { _ } -> "" - in string_of_bitset_aux bs - -(* To print addresses/offsets *) -let string_of_int32 = Printf.sprintf "0x%08lx" -let string_of_int64 = Printf.sprintf "0x%08Lx" -(* To print counts/indices *) -let string_of_int32i = Int32.to_string -let string_of_int64i = Int64.to_string - -let string_of_positive p = string_of_int32i (positive_int32 p) - -let string_of_z z = string_of_int32 (z_int32 z) - -let sorted_lookup (compare: 'a -> 'b -> int) (arr: 'a array) (v: 'b): 'a option = - let rec sorted_lookup_aux (i_from: int) (i_to: int): 'a option = - if i_from > i_to - then None - else - let i_mid = (i_from + i_to) / 2 in - let comp = compare arr.(i_mid) v in - if comp < 0 (* v_mid < v *) - then sorted_lookup_aux (i_mid + 1) i_to - else if comp > 0 - then sorted_lookup_aux i_from (i_mid - 1) - else Some(arr.(i_mid)) - in sorted_lookup_aux 0 (Array.length arr - 1) - -let list_false_indices a = - filter_some (Array.(to_list (mapi (fun ndx b -> if b then None else Some(ndx)) a))) diff --git a/checklink/Makefile b/checklink/Makefile deleted file mode 100644 index 1518e2c6..00000000 --- a/checklink/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -TESTS=c arcode lzw lzss raytracer regression spass - -.PHONY: all $(TESTS) - -all: $(TESTS) - -CL=../cchecklink $(ARGS) -TESTDIR=../test - -C=aes almabench binarytrees bisect chomp fannkuch fft fib integr knucleotide \ - lists mandelbrot nbody nsievebits nsieve perlin qsort sha1 spectral vmach - -c: - for x in $(C); do \ - echo $(CL) $(TESTDIR)/c/$$x.compcert $(TESTDIR)/c/$$x.sdump; \ - $(CL) $(TESTDIR)/c/$$x.compcert $(TESTDIR)/c/$$x.sdump; \ - done - -ARCODE=optlist bitfile arcode armain -ARCODE_SDUMP=$(addsuffix .sdump, $(ARCODE)) -arcode: - $(CL) $(addprefix $(TESTDIR)/compression/, arcode $(ARCODE_SDUMP)) - -LZW=optlist bitfile lzwencode lzwdecode lzwmain -LZW_SDUMP=$(addsuffix .sdump, $(LZW)) -lzw: - $(CL) $(addprefix $(TESTDIR)/compression/, lzw $(LZW_SDUMP)) - -LZSS=optlist bitfile lzvars lzhash lzencode lzdecode -LZSS_SDUMP=$(addsuffix .sdump, $(LZSS)) -lzss: - $(CL) $(addprefix $(TESTDIR)/compression/, lzss $(LZSS_SDUMP)) - -RAYTRACER_SDUMP=`ls $(TESTDIR)/raytracer/*.sdump` -raytracer: - $(CL) $(TESTDIR)/raytracer/render $(RAYTRACER_SDUMP) - -SDUMP_COMPCERT=`echo $$x | sed s/sdump/compcert/` -REGRESSION_SDUMP=`ls $(TESTDIR)/regression/*.sdump` -regression: - for x in $(REGRESSION_SDUMP); \ - do \ - if [ -f $(SDUMP_COMPCERT) ] ; \ - then \ - echo $(CL) $(SDUMP_COMPCERT) $$x; \ - $(CL) $(SDUMP_COMPCERT) $$x ; \ - fi ; \ - done - -SPASS_SDUMP=`ls $(TESTDIR)/spass/*.sdump` -spass: - $(CL) $(TESTDIR)/spass/spass $(SPASS_SDUMP) diff --git a/checklink/PPC_parsers.ml b/checklink/PPC_parsers.ml deleted file mode 100644 index 5fb8c2d9..00000000 --- a/checklink/PPC_parsers.ml +++ /dev/null @@ -1,397 +0,0 @@ -open Library -open PPC_types - -let parse_instr bs = - bitmatch bs with - | { 31:6; d:5; a:5; b:5; oe:1; 266:9; rc:1 } - -> ADDx(d, a, b, oe, rc) - | { 31:6; d:5; a:5; b:5; oe:1; 10:9; rc:1 } - -> ADDCx(d, a, b, oe, rc) - | { 31:6; d:5; a:5; b:5; oe:1; 138:9; rc:1 } - -> ADDEx(d, a, b, oe, rc) - | { 14:6; d:5; a:5; simm:16:bitstring } - -> ADDI(d, a, simm) - | { 12:6; d:5; a:5; simm:16:bitstring } - -> ADDIC(d, a, simm) - | { 13:6; d:5; a:5; simm:16:bitstring } - -> ADDIC_(d, a, simm) - | { 15:6; d:5; a:5; simm:16 } - -> ADDIS(d, a, simm) - | { 31:6; d:5; a:5; 0:5; oe:1; 234:9; rc:1 } - -> ADDMEx(d, a, oe, rc) - | { 31:6; d:5; a:5; 0:5; oe:1; 202:9; rc:1 } - -> ADDZEx(d, a, oe, rc) - | { 31:6; s:5; a:5; b:5; 28:10; rc:1 } - -> ANDx(s, a, b, rc) - | { 31:6; s:5; a:5; b:5; 60:10; rc:1 } - -> ANDCx(s, a, b, rc) - | { 28:6; s:5; a:5; uimm:16 } - -> ANDI_(s, a, uimm) - | { 29:6; s:5; a:5; uimm:16 } - -> ANDIS_(s, a, uimm) - | { 18:6; li:24:bitstring; aa:1; lk:1 } - -> Bx(li, aa, lk) - | { 16:6; bo:5:bitstring; bi:5; bd:14:bitstring; aa:1; lk:1 } - -> BCx(bo, bi, bd, aa, lk) - | { 19:6; bo:5:bitstring; bi:5; 0:5; 528:10; lk:1 } - -> BCCTRx(bo, bi, lk) - | { 19:6; bo:5:bitstring; bi:5; 0:5; 16:10; lk:1 } - -> BCLRx(bo, bi, lk) - | { 31:6; crfD:3; false:1; l:1; a:5; b:5; 0:10; false:1 } - -> CMP(crfD, l, a, b) - | { 11:6; crfD:3; false:1; l:1; a:5; simm:16:bitstring } - -> CMPI(crfD, l, a, simm) - | { 31:6; crfD:3; false:1; l:1; a:5; b:5; 32:10; false:1 } - -> CMPL(crfD, l, a, b) - | { 10:6; crfD:3; false:1; l:1; a:5; uimm:16 } - -> CMPLI(crfD, l, a, uimm) - | { 31:6; s:5; a:5; 0:5; 26:10; rc:1 } - -> CNTLZWx(s, a, rc) - | { 19:6; crbD:5; crbA:5; crbB:5; 257:10; false:1 } - -> CRAND(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 129:10; false:1 } - -> CRANDC(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 289:10; false:1 } - -> CREQV(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 225:10; false:1 } - -> CRNAND(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 33:10; false:1 } - -> CRNOR(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 449:10; false:1 } - -> CROR(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 417:10; false:1 } - -> CRORC(crbD, crbA, crbB) - | { 19:6; crbD:5; crbA:5; crbB:5; 193:10; false:1 } - -> CRXOR(crbD, crbA, crbB) - | { 31:6; 0:5; a:5; b:5; 758:10; false:1 } - -> DCBA(a, b) - | { 31:6; 0:5; a:5; b:5; 86:10; false:1 } - -> DCBF(a, b) - | { 31:6; 0:5; a:5; b:5; 470:10; false:1 } - -> DCBI(a, b) - | { 31:6; 0:5; a:5; b:5; 54:10; false:1 } - -> DCBST(a, b) - | { 31:6; 0:5; a:5; b:5; 278:10; false:1 } - -> DCBT(a, b) - | { 31:6; 0:5; a:5; b:5; 246:10; false:1 } - -> DCBTST(a, b) - | { 31:6; 0:5; a:5; b:5; 1014:10; false:1 } - -> DCBZ(a, b) - | { 31:6; d:5; a:5; b:5; oe:1; 491:9; rc:1 } - -> DIVWx(d, a, b, oe, rc) - | { 31:6; d:5; a:5; b:5; oe:1; 459:9; rc:1 } - -> DIVWUx(d, a, b, oe, rc) - | { 31:6; d:5; a:5; b:5; 310:10; false:1 } - -> ECIWX(d, a, b) - | { 31:6; s:5; a:5; b:5; 438:10; false:1 } - -> ECOWX(s, a, b) - | { 31:6; 0:5; 0:5; 0:5; 854:10; false:1 } - -> EIEIO - | { 31:6; s:5; a:5; b:5; 284:10; rc:1 } - -> EQVx(s, a, b, rc) - | { 31:6; s:5; a:5; 0:5; 954:10; rc:1 } - -> EXTSBx(s, a, rc) - | { 31:6; s:5; a:5; 0:5; 922:10; rc:1 } - -> EXTSHx(s, a, rc) - | { 63:6; d:5; 0:5; b:5; 264:10; rc:1 } - -> FABSx(d, b, rc) - | { 63:6; d:5; a:5; b:5; 0:5; 21:5; rc:1 } - -> FADDx(d, a, b, rc) - | { 59:6; d:5; a:5; b:5; 0:5; 21:5; rc:1 } - -> FADDSx(d, a, b, rc) - | { 63:6; crfD:3; 0:2; a:5; b:5; 32:10; false:1 } - -> FCMPO(crfD, a, b) - | { 63:6; crfD:3; 0:2; a:5; b:5; 0:10; false:1 } - -> FCMPU(crfD, a, b) - | { 63:6; d:5; 0:5; b:5; 14:10; rc:1 } - -> FCTIWx(d, b, rc) - | { 63:6; d:5; 0:5; b:5; 15:10; rc:1 } - -> FCTIWZx(d, b, rc) - | { 63:6; d:5; a:5; b:5; 0:5; 18:5; rc:1 } - -> FDIVx(d, a, b, rc) - | { 59:6; d:5; a:5; b:5; 0:5; 18:5; rc:1 } - -> FDIVSx(d, a, b, rc) - | { 63:6; d:5; a:5; b:5; c:5; 29:5; rc:1 } - -> FMADDx(d, a, b, c, rc) - | { 59:6; d:5; a:5; b:5; c:5; 29:5; rc:1 } - -> FMADDSx(d, a, b, c, rc) - | { 63:6; d:5; 0:5; b:5; 72:10; rc:1 } - -> FMRx(d, b, rc) - | { 63:6; d:5; a:5; b:5; c:5; 28:5; rc:1 } - -> FMSUBx(d, a, b, c, rc) - | { 59:6; d:5; a:5; b:5; c:5; 28:5; rc:1 } - -> FMSUBSx(d, a, b, c, rc) - | { 63:6; d:5; a:5; 0:5; c:5; 25:5; rc:1 } - -> FMULx(d, a, c, rc) - | { 59:6; d:5; a:5; 0:5; c:5; 25:5; rc:1 } - -> FMULSx(d, a, c, rc) - | { 63:6; d:5; 0:5; b:5; 136:10; rc:1 } - -> FNABSx(d, b, rc) - | { 63:6; d:5; 0:5; b:5; 40:10; rc:1 } - -> FNEGx(d, b, rc) - | { 63:6; d:5; a:5; b:5; c:5; 31:5; rc:1 } - -> FNMADDx(d, a, b, c, rc) - | { 59:6; d:5; a:5; b:5; c:5; 31:5; rc:1 } - -> FNMADDSx(d, a, b, c, rc) - | { 63:6; d:5; a:5; b:5; c:5; 30:5; rc:1 } - -> FNMSUBx(d, a, b, c, rc) - | { 59:6; d:5; a:5; b:5; c:5; 30:5; rc:1 } - -> FNMSUBSx(d, a, b, c, rc) - | { 59:6; d:5; 0:5; b:5; 0:5; 24:5; rc:1 } - -> FRESx(d, b, rc) - | { 63:6; d:5; 0:5; b:5; 12:10; rc:1 } - -> FRSPx(d, b, rc) - | { 63:6; d:5; 0:5; b:5; 0:5; 26:5; rc:1 } - -> FRSQRTEx(d, b, rc) - | { 63:6; d:5; a:5; b:5; c:5; 23:5; rc:1 } - -> FSELx(d, a, b, c, rc) - | { 63:6; d:5; 0:5; b:5; 0:5; 22:5; rc:1 } - -> FSQRTx(d, b, rc) - | { 59:6; d:5; 0:5; b:5; 0:5; 22:5; rc:1 } - -> FSQRTSx(d, b, rc) - | { 63:6; d:5; a:5; b:5; 0:5; 20:5; rc:1 } - -> FSUBx(d, a, b, rc) - | { 59:6; d:5; a:5; b:5; 0:5; 20:5; rc:1 } - -> FSUBSx(d, a, b, rc) - | { 31:6; 0:5; a:5; b:5; 982:10; false:1 } - -> ICBI(a, b) - | { 19:6; 0:5; 0:5; 0:5; 150:10; false:1 } - -> ISYNC - | { 34:6; d:5; a:5; dd:16:bitstring } - -> LBZ(d, a, dd) - | { 35:6; d:5; a:5; dd:16:bitstring } - -> LBZU(d, a, dd) - | { 31:6; d:5; a:5; b:5; 119:10; false:1 } - -> LBZUX(d, a, b) - | { 31:6; d:5; a:5; b:5; 87:10; false:1 } - -> LBZX(d, a, b) - | { 50:6; d:5; a:5; dd:16:bitstring } - -> LFD(d, a, dd) - | { 51:6; d:5; a:5; dd:16:bitstring } - -> LFDU(d, a, dd) - | { 31:6; d:5; a:5; b:5; 631:10; false:1 } - -> LFDUX(d, a, b) - | { 31:6; d:5; a:5; b:5; 599:10; false:1 } - -> LFDX(d, a, b) - | { 48:6; d:5; a:5; dd:16:bitstring } - -> LFS(d, a, dd) - | { 49:6; d:5; a:5; dd:16:bitstring } - -> LFSU(d, a, dd) - | { 31:6; d:5; a:5; b:5; 567:10; false:1 } - -> LFSUX(d, a, b) - | { 31:6; d:5; a:5; b:5; 535:10; false:1 } - -> LFSX(d, a, b) - | { 42:6; d:5; a:5; dd:16:bitstring } - -> LHA(d, a, dd) - | { 43:6; d:5; a:5; dd:16:bitstring } - -> LHAU(d, a, dd) - | { 31:6; d:5; a:5; b:5; 375:10; false:1 } - -> LHAUX(d, a, b) - | { 31:6; d:5; a:5; b:5; 343:10; false:1 } - -> LHAX(d, a, b) - | { 31:6; d:5; a:5; b:5; 790:10; false:1 } - -> LHBRX(d, a, b) - | { 40:6; d:5; a:5; dd:16:bitstring } - -> LHZ(d, a, dd) - | { 41:6; d:5; a:5; dd:16:bitstring } - -> LHZU(d, a, dd) - | { 31:6; d:5; a:5; b:5; 311:10; false:1 } - -> LHZUX(d, a, b) - | { 31:6; d:5; a:5; b:5; 279:10; false:1 } - -> LHZX(d, a, b) - | { 46:6; d:5; a:5; dd:16 } - -> LMW(d, a, dd) - | { 31:6; d:5; a:5; nb:5; 597:10; false:1 } - -> LSWI(d, a, nb) - | { 31:6; d:5; a:5; b:5; 533:10; false:1 } - -> LSWX(d, a, b) - | { 31:6; d:5; a:5; b:5; 20:10; false:1 } - -> LWARX(d, a, b) - | { 31:6; d:5; a:5; b:5; 534:10; false:1 } - -> LWBRX(d, a, b) - | { 32:6; d:5; a:5; dd:16:bitstring } - -> LWZ(d, a, dd) - | { 33:6; d:5; a:5; dd:16:bitstring } - -> LWZU(d, a, dd) - | { 31:6; d:5; a:5; b:5; 55:10; false:1 } - -> LWZUX(d, a, b) - | { 31:6; d:5; a:5; b:5; 23:10; false:1 } - -> LWZX(d, a, b) - | { 19:6; crfD:3; 0:2; crfS:3; 0:2; 0:5; 0:10; false:1 } - -> MCRF(crfD, crfS) - | { 63:6; crfD:3; 0:2; crfS:3; 0:2; 0:5; 64:10; false:1 } - -> MCRFS(crfD, crfS) - | { 31:6; crfD:3; 0:2; 0:5; 0:5; 0:10; false:1 } - -> MCRXR(crfD) - | { 31:6; d:5; 0:5; 0:5; 19:10; false:1 } - -> MFCR(d) - | { 63:6; d:5; 0:5; 0:5; 583:10; rc:1 } - -> MFFSx(d, rc) - | { 31:6; d:5; 0:5; 0:5; 83:10; false:1 } - -> MFMSR(d) - | { 31:6; d:5; spr:10:bitstring; 339:10; false:1 } - -> MFSPR(d, spr) - | { 31:6; d:5; false:1; sr:4; 0:5; 595:10; false:1 } - -> MFSR(d, sr) - | { 31:6; d:5; 0:5; b:5; 659:10; false:1 } - -> MFSRIN(d, b) - | { 31:6; d:5; tbr:10; 371:10; false:1 } - -> MFTB(d, tbr) - | { 31:6; s:5; false:1; crm:8; false:1; 144:10; false:1 } - -> MTCRF(s, crm) - | { 63:6; crbD:5; 0:5; 0:5; 70:10; rc:1 } - -> MTFSB0x(crbD, rc) - | { 63:6; crbD:5; 0:5; 0:5; 38:10; rc:1 } - -> MTFSB1x(crbD, rc) - | { 63:6; false:1; fm:8; false:1; b:5; 711:10; rc:1 } - -> MTFSF(fm, b, rc) - | { 63:6; crfD:3; 0:2; 0:5; imm:4; false:1; 134:10; rc:1 } - -> MTFSFIx(crfD, imm, rc) - | { 31:6; s:5; 0:5; 0:5; 146:10; false:1 } - -> MTMSR(s) - | { 31:6; s:5; spr:10:bitstring; 467:10; false:1 } - -> MTSPR(s, spr) - | { 31:6; s:5; false:1; sr:4; 0:5; 210:10; false:1 } - -> MTSR(s, sr) - | { 31:6; s:5; 0:5; b:5; 242:10; false:1 } - -> MTSRIN(s, b) - | { 31:6; d:5; a:5; b:5; false:1; 75:9; rc:1 } - -> MULHWx(d, a, b, rc) - | { 31:6; d:5; a:5; b:5; false:1; 11:9; rc:1 } - -> MULHWUx(d, a, b, rc) - | { 7:6; d:5; a:5; simm:16:bitstring } - -> MULLI(d, a, simm) - | { 31:6; id:5; a:5; b:5; oe:1; 235:9; rc:1 } - -> MULLWx(id, a, b, oe, rc) - | { 31:6; s:5; a:5; b:5; 476:10; rc:1 } - -> NANDx(s, a, b, rc) - | { 31:6; d:5; a:5; 0:5; oe:1; 104:9; rc:1 } - -> NEGx(d, a, oe, rc) - | { 31:6; s:5; a:5; b:5; 124:10; rc:1 } - -> NORx(s, a, b, rc) - | { 31:6; s:5; a:5; b:5; 444:10; rc:1 } - -> ORx(s, a, b, rc) - | { 31:6; s:5; a:5; b:5; 412:10; rc:1 } - -> ORCx(s, a, b, rc) - | { 24:6; s:5; a:5; uimm:16 } - -> ORI(s, a, uimm) - | { 25:6; s:5; a:5; uimm:16 } - -> ORIS(s, a, uimm) - | { 19:6; 0:5; 0:5; 0:5; 50:10; false:1 } - -> RFI - | { 20:6; s:5; a:5; sh:5; mb:5; me:5; rc:1 } - -> RLWIMIx(s, a, sh, mb, me, rc) - | { 21:6; s:5; a:5; sh:5; mb:5; me:5; rc:1 } - -> RLWINMx(s, a, sh, mb, me, rc) - | { 23:6; s:5; a:5; b:5; mb:5; me:5; rc:1 } - -> RLWNMx(s, a, b, mb, me, rc) - | { 17:6; 0:5; 0:5; 0:14; true:1; false:1 } - -> SC - | { 31:6; s:5; a:5; b:5; 24:10; rc:1 } - -> SLWx(s, a, b, rc) - | { 31:6; s:5; a:5; b:5; 792:10; rc:1 } - -> SRAWx(s, a, b, rc) - | { 31:6; s:5; a:5; sh:5; 824:10; rc:1 } - -> SRAWIx(s, a, sh, rc) - | { 31:6; s:5; a:5; b:5; 536:10; rc:1 } - -> SRWx(s, a, b, rc) - | { 38:6; s:5; a:5; dd:16:bitstring } - -> STB(s, a, dd) - | { 39:6; s:5; a:5; dd:16:bitstring } - -> STBU(s, a, dd) - | { 31:6; s:5; a:5; b:5; 247:10; false:1 } - -> STBUX(s, a, b) - | { 31:6; s:5; a:5; b:5; 215:10; false:1 } - -> STBX(s, a, b) - | { 54:6; s:5; a:5; dd:16:bitstring } - -> STFD(s, a, dd) - | { 55:6; s:5; a:5; dd:16:bitstring } - -> STFDU(s, a, dd) - | { 31:6; s:5; a:5; b:5; 759:10; false:1 } - -> STFDUX(s, a, b) - | { 31:6; s:5; a:5; b:5; 727:10; false:1 } - -> STFDX(s, a, b) - | { 31:6; s:5; a:5; b:5; 983:10; false:1 } - -> STFIWX(s, a, b) - | { 52:6; s:5; a:5; dd:16:bitstring } - -> STFS(s, a, dd) - | { 53:6; s:5; a:5; dd:16:bitstring } - -> STFSU(s, a, dd) - | { 31:6; s:5; a:5; b:5; 695:10; false:1 } - -> STFSUX(s, a, b) - | { 31:6; s:5; a:5; b:5; 663:10; false:1 } - -> STFSX(s, a, b) - | { 44:6; s:5; a:5; dd:16:bitstring } - -> STH(s, a, dd) - | { 31:6; s:5; a:5; b:5; 918:10; false:1 } - -> STHBRX(s, a, b) - | { 45:6; s:5; a:5; dd:16:bitstring } - -> STHU(s, a, dd) - | { 31:6; s:5; a:5; b:5; 439:10; false:1 } - -> STHUX(s, a, b) - | { 31:6; s:5; a:5; b:5; 407:10; false:1 } - -> STHX(s, a, b) - | { 47:6; s:5; a:5; dd:16 } - -> STMW(s, a, dd) - | { 31:6; s:5; a:5; nb:5; 725:10; false:1 } - -> STSWI(s, a, nb) - | { 31:6; s:5; a:5; b:5; 661:10; false:1 } - -> STSWX(s, a, b) - | { 36:6; s:5; a:5; dd:16:bitstring } - -> STW(s, a, dd) - | { 31:6; s:5; a:5; b:5; 662:10; false:1 } - -> STWBRX(s, a, b) - | { 31:6; s:5; a:5; b:5; 150:10; false:1 } - -> STWCX_(s, a, b) - | { 37:6; s:5; a:5; dd:16:bitstring } - -> STWU(s, a, dd) - | { 31:6; s:5; a:5; b:5; 183:10; false:1 } - -> STWUX(s, a, b) - | { 31:6; s:5; a:5; b:5; 151:10; false:1 } - -> STWX(s, a, b) - | { 31:6; d:5; a:5; b:5; oe:1; 40:9; rc:1 } - -> SUBFx(d, a, b, oe, rc) - | { 31:6; d:5; a:5; b:5; oe:1; 8:9; rc:1 } - -> SUBFCx(d, a, b, oe, rc) - | { 31:6; d:5; a:5; b:5; oe:1; 136:9; rc:1 } - -> SUBFEx(d, a, b, oe, rc) - | { 8:6; d:5; a:5; simm:16:bitstring } - -> SUBFIC(d, a, simm) - | { 31:6; d:5; a:5; 0:5; oe:1; 232:9; rc:1 } - -> SUBFMEx(d, a, oe, rc) - | { 31:6; d:5; a:5; 0:5; oe:1; 200:9; rc:1 } - -> SUBFZEx(d, a, oe, rc) - | { 31:6; 0:5; 0:5; 0:5; 598:10; false:1 } - -> SYNC - | { 31:6; 0:5; 0:5; 0:5; 370:10; false:1 } - -> TLBIA - | { 31:6; 0:5; 0:5; b:5; 306:10; false:1 } - -> TLBIE(b) - | { 31:6; 0:5; 0:5; 0:5; 566:10; false:1 } - -> TLBSYNC - | { 31:6; t:5:bitstring; a:5; b:5; 4:10; false:1 } - -> TW(t, a, b) - | { 3:6; t:5:bitstring; a:5; simm:16 } - -> TWI(t, a, simm) - | { 31:6; s:5; a:5; b:5; 316:10; rc:1 } - -> XORx(s, a, b, rc) - | { 26:6; s:5; a:5; uimm:16 } - -> XORI(s, a, uimm) - | { 27:6; s:5; a:5; uimm:16 } - -> XORIS(s, a, uimm) - | { bits:32:bitstring } - -> UNKNOWN(bits) - -let rec parse_code_as_list bs = - bitmatch bs with - | { instr:32:bitstring; rest:-1:bitstring } -> - parse_instr instr :: parse_code_as_list rest - | { rest:-1:bitstring } -> - if Bitstring.bitstring_length rest = 0 - then [] - else assert false - -let parse_nth_instr bs n = parse_instr (Bitstring.subbitstring bs (n * 32) 32) - -let parse_code_as_array (bs: bitstring) (num: int): instr array = - Array.init num (parse_nth_instr bs) diff --git a/checklink/PPC_printers.ml b/checklink/PPC_printers.ml deleted file mode 100644 index 5aa9a040..00000000 --- a/checklink/PPC_printers.ml +++ /dev/null @@ -1,203 +0,0 @@ -open Library -open PPC_types - -let string_of_eireg r = "r" ^ string_of_int r - -let string_of_efreg f = "fr" ^ string_of_int f - -let string_of_bool b = if b then "1" else "0" - -let string_of_instr = function -| ADDx (r0, r1, r2, b3, b4) -> "ADDx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| ADDCx (r0, r1, r2, b3, b4) -> "ADDCx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| ADDEx (r0, r1, r2, b3, b4) -> "ADDEx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| ADDI (r0, r1, b2) -> "ADDI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| ADDIC (r0, r1, b2) -> "ADDIC(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| ADDIC_ (r0, r1, b2) -> "ADDIC_(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| ADDIS (r0, r1, i2) -> "ADDIS(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| ADDMEx (r0, r1, b2, b3) -> "ADDMEx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ", " ^ string_of_bool b3 ^ ")" -| ADDZEx (r0, r1, b2, b3) -> "ADDZEx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ", " ^ string_of_bool b3 ^ ")" -| ANDx (r0, r1, r2, b3) -> "ANDx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| ANDCx (r0, r1, r2, b3) -> "ANDCx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| ANDI_ (r0, r1, i2) -> "ANDI_(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| ANDIS_ (r0, r1, i2) -> "ANDIS_(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| Bx (b0, b1, b2) -> "Bx(" ^ string_of_bitstring b0 ^ ", " ^ string_of_bool b1 ^ ", " ^ string_of_bool b2 ^ ")" -| BCx (b0, i1, b2, b3, b4) -> "BCx(" ^ string_of_bitstring b0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_bitstring b2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| BCCTRx (b0, i1, b2) -> "BCCTRx(" ^ string_of_bitstring b0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_bool b2 ^ ")" -| BCLRx (b0, i1, b2) -> "BCLRx(" ^ string_of_bitstring b0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_bool b2 ^ ")" -| CMP (i0, b1, r2, r3) -> "CMP(" ^ string_of_int i0 ^ ", " ^ string_of_bool b1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_eireg r3 ^ ")" -| CMPI (i0, b1, r2, b3) -> "CMPI(" ^ string_of_int i0 ^ ", " ^ string_of_bool b1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bitstring b3 ^ ")" -| CMPL (i0, b1, r2, r3) -> "CMPL(" ^ string_of_int i0 ^ ", " ^ string_of_bool b1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_eireg r3 ^ ")" -| CMPLI (i0, b1, r2, i3) -> "CMPLI(" ^ string_of_int i0 ^ ", " ^ string_of_bool b1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_int i3 ^ ")" -| CNTLZWx (r0, r1, b2) -> "CNTLZWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ")" -| CRAND (i0, i1, i2) -> "CRAND(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CRANDC (i0, i1, i2) -> "CRANDC(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CREQV (i0, i1, i2) -> "CREQV(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CRNAND (i0, i1, i2) -> "CRNAND(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CRNOR (i0, i1, i2) -> "CRNOR(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CROR (i0, i1, i2) -> "CROR(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CRORC (i0, i1, i2) -> "CRORC(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| CRXOR (i0, i1, i2) -> "CRXOR(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_int i2 ^ ")" -| DCBA (r0, r1) -> "DCBA(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DCBF (r0, r1) -> "DCBF(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DCBI (r0, r1) -> "DCBI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DCBST (r0, r1) -> "DCBST(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DCBT (r0, r1) -> "DCBT(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DCBTST (r0, r1) -> "DCBTST(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DCBZ (r0, r1) -> "DCBZ(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| DIVWx (r0, r1, r2, b3, b4) -> "DIVWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| DIVWUx (r0, r1, r2, b3, b4) -> "DIVWUx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| ECIWX (r0, r1, r2) -> "ECIWX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| ECOWX (r0, r1, r2) -> "ECOWX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| EIEIO -> "EIEIO" -| EQVx (r0, r1, r2, b3) -> "EQVx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| EXTSBx (r0, r1, b2) -> "EXTSBx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ")" -| EXTSHx (r0, r1, b2) -> "EXTSHx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ")" -| FABSx (f0, f1, b2) -> "FABSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FADDx (f0, f1, f2, b3) -> "FADDx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FADDSx (f0, f1, f2, b3) -> "FADDSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FCMPO (i0, f1, f2) -> "FCMPO(" ^ string_of_int i0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ")" -| FCMPU (i0, f1, f2) -> "FCMPU(" ^ string_of_int i0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ")" -| FCTIWx (f0, f1, b2) -> "FCTIWx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FCTIWZx (f0, f1, b2) -> "FCTIWZx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FDIVx (f0, f1, f2, b3) -> "FDIVx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FDIVSx (f0, f1, f2, b3) -> "FDIVSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FMADDx (f0, f1, f2, f3, b4) -> "FMADDx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FMADDSx (f0, f1, f2, f3, b4) -> "FMADDSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FMRx (f0, f1, b2) -> "FMRx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FMSUBx (f0, f1, f2, f3, b4) -> "FMSUBx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FMSUBSx (f0, f1, f2, f3, b4) -> "FMSUBSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FMULx (f0, f1, f2, b3) -> "FMULx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FMULSx (f0, f1, f2, b3) -> "FMULSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FNABSx (f0, f1, b2) -> "FNABSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FNEGx (f0, f1, b2) -> "FNEGx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FNMADDx (f0, f1, f2, f3, b4) -> "FNMADDx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FNMADDSx (f0, f1, f2, f3, b4) -> "FNMADDSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FNMSUBx (f0, f1, f2, f3, b4) -> "FNMSUBx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FNMSUBSx (f0, f1, f2, f3, b4) -> "FNMSUBSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FRESx (f0, f1, b2) -> "FRESx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FRSPx (f0, f1, b2) -> "FRSPx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FRSQRTEx (f0, f1, b2) -> "FRSQRTEx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FSELx (f0, f1, f2, f3, b4) -> "FSELx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_efreg f3 ^ ", " ^ string_of_bool b4 ^ ")" -| FSQRTx (f0, f1, b2) -> "FSQRTx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FSQRTSx (f0, f1, b2) -> "FSQRTSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| FSUBx (f0, f1, f2, b3) -> "FSUBx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| FSUBSx (f0, f1, f2, b3) -> "FSUBSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_efreg f2 ^ ", " ^ string_of_bool b3 ^ ")" -| ICBI (r0, r1) -> "ICBI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| ISYNC -> "ISYNC" -| LBZ (r0, r1, b2) -> "LBZ(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LBZU (r0, r1, b2) -> "LBZU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LBZUX (r0, r1, r2) -> "LBZUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LBZX (r0, r1, r2) -> "LBZX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LFD (f0, r1, b2) -> "LFD(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LFDU (f0, r1, b2) -> "LFDU(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LFDUX (f0, r1, r2) -> "LFDUX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LFDX (f0, r1, r2) -> "LFDX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LFS (f0, r1, b2) -> "LFS(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LFSU (f0, r1, b2) -> "LFSU(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LFSUX (f0, r1, r2) -> "LFSUX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LFSX (f0, r1, r2) -> "LFSX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LHA (r0, r1, b2) -> "LHA(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LHAU (r0, r1, b2) -> "LHAU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LHAUX (r0, r1, r2) -> "LHAUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LHAX (r0, r1, r2) -> "LHAX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LHBRX (r0, r1, r2) -> "LHBRX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LHZ (r0, r1, b2) -> "LHZ(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LHZU (r0, r1, b2) -> "LHZU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LHZUX (r0, r1, r2) -> "LHZUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LHZX (r0, r1, r2) -> "LHZX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LMW (r0, r1, i2) -> "LMW(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| LSWI (r0, r1, r2) -> "LSWI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LSWX (r0, r1, r2) -> "LSWX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LWARX (r0, r1, r2) -> "LWARX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LWBRX (r0, r1, r2) -> "LWBRX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LWZ (r0, r1, b2) -> "LWZ(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LWZU (r0, r1, b2) -> "LWZU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| LWZUX (r0, r1, r2) -> "LWZUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| LWZX (r0, r1, r2) -> "LWZX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| MCRF (i0, i1) -> "MCRF(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ")" -| MCRFS (i0, i1) -> "MCRFS(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ")" -| MCRXR (i0) -> "MCRXR(" ^ string_of_int i0 ^ ")" -| MFCR (r0) -> "MFCR(" ^ string_of_eireg r0 ^ ")" -| MFFSx (f0, b1) -> "MFFSx(" ^ string_of_efreg f0 ^ ", " ^ string_of_bool b1 ^ ")" -| MFMSR (r0) -> "MFMSR(" ^ string_of_eireg r0 ^ ")" -| MFSPR (r0, b1) -> "MFSPR(" ^ string_of_eireg r0 ^ ", " ^ string_of_bitstring b1 ^ ")" -| MFSR (r0, i1) -> "MFSR(" ^ string_of_eireg r0 ^ ", " ^ string_of_int i1 ^ ")" -| MFSRIN (r0, r1) -> "MFSRIN(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| MFTB (r0, i1) -> "MFTB(" ^ string_of_eireg r0 ^ ", " ^ string_of_int i1 ^ ")" -| MTCRF (r0, i1) -> "MTCRF(" ^ string_of_eireg r0 ^ ", " ^ string_of_int i1 ^ ")" -| MTFSB0x (i0, b1) -> "MTFSB0x(" ^ string_of_int i0 ^ ", " ^ string_of_bool b1 ^ ")" -| MTFSB1x (i0, b1) -> "MTFSB1x(" ^ string_of_int i0 ^ ", " ^ string_of_bool b1 ^ ")" -| MTFSF (i0, f1, b2) -> "MTFSF(" ^ string_of_int i0 ^ ", " ^ string_of_efreg f1 ^ ", " ^ string_of_bool b2 ^ ")" -| MTFSFIx (i0, i1, b2) -> "MTFSFIx(" ^ string_of_int i0 ^ ", " ^ string_of_int i1 ^ ", " ^ string_of_bool b2 ^ ")" -| MTMSR (r0) -> "MTMSR(" ^ string_of_eireg r0 ^ ")" -| MTSPR (r0, b1) -> "MTSPR(" ^ string_of_eireg r0 ^ ", " ^ string_of_bitstring b1 ^ ")" -| MTSR (r0, i1) -> "MTSR(" ^ string_of_eireg r0 ^ ", " ^ string_of_int i1 ^ ")" -| MTSRIN (r0, r1) -> "MTSRIN(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ")" -| MULHWx (r0, r1, r2, b3) -> "MULHWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| MULHWUx (r0, r1, r2, b3) -> "MULHWUx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| MULLI (r0, r1, b2) -> "MULLI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| MULLWx (r0, r1, r2, b3, b4) -> "MULLWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| NANDx (r0, r1, r2, b3) -> "NANDx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| NEGx (r0, r1, b2, b3) -> "NEGx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ", " ^ string_of_bool b3 ^ ")" -| NORx (r0, r1, r2, b3) -> "NORx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| ORx (r0, r1, r2, b3) -> "ORx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| ORCx (r0, r1, r2, b3) -> "ORCx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| ORI (r0, r1, i2) -> "ORI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| ORIS (r0, r1, i2) -> "ORIS(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| RFI -> "RFI" -| RLWIMIx (r0, r1, i2, i3, i4, b5) -> "RLWIMIx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ", " ^ string_of_int i3 ^ ", " ^ string_of_int i4 ^ ", " ^ string_of_bool b5 ^ ")" -| RLWINMx (r0, r1, i2, i3, i4, b5) -> "RLWINMx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ", " ^ string_of_int i3 ^ ", " ^ string_of_int i4 ^ ", " ^ string_of_bool b5 ^ ")" -| RLWNMx (r0, r1, r2, i3, i4, b5) -> "RLWNMx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_int i3 ^ ", " ^ string_of_int i4 ^ ", " ^ string_of_bool b5 ^ ")" -| SC -> "SC" -| SLWx (r0, r1, r2, b3) -> "SLWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| SRAWx (r0, r1, r2, b3) -> "SRAWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| SRAWIx (r0, r1, i2, b3) -> "SRAWIx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ", " ^ string_of_bool b3 ^ ")" -| SRWx (r0, r1, r2, b3) -> "SRWx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| STB (r0, r1, b2) -> "STB(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STBU (r0, r1, b2) -> "STBU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STBUX (r0, r1, r2) -> "STBUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STBX (r0, r1, r2) -> "STBX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STFD (f0, r1, b2) -> "STFD(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STFDU (f0, r1, b2) -> "STFDU(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STFDUX (f0, r1, r2) -> "STFDUX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STFDX (f0, r1, r2) -> "STFDX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STFIWX (r0, r1, r2) -> "STFIWX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STFS (f0, r1, b2) -> "STFS(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STFSU (f0, r1, b2) -> "STFSU(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STFSUX (f0, r1, r2) -> "STFSUX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STFSX (f0, r1, r2) -> "STFSX(" ^ string_of_efreg f0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STH (r0, r1, b2) -> "STH(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STHBRX (r0, r1, r2) -> "STHBRX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STHU (r0, r1, b2) -> "STHU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STHUX (r0, r1, r2) -> "STHUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STHX (r0, r1, r2) -> "STHX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STMW (r0, r1, i2) -> "STMW(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| STSWI (r0, r1, r2) -> "STSWI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STSWX (r0, r1, r2) -> "STSWX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STW (r0, r1, b2) -> "STW(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STWBRX (r0, r1, r2) -> "STWBRX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STWCX_ (r0, r1, r2) -> "STWCX_(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STWU (r0, r1, b2) -> "STWU(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| STWUX (r0, r1, r2) -> "STWUX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| STWX (r0, r1, r2) -> "STWX(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| SUBFx (r0, r1, r2, b3, b4) -> "SUBFx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| SUBFCx (r0, r1, r2, b3, b4) -> "SUBFCx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| SUBFEx (r0, r1, r2, b3, b4) -> "SUBFEx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ", " ^ string_of_bool b4 ^ ")" -| SUBFIC (r0, r1, b2) -> "SUBFIC(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bitstring b2 ^ ")" -| SUBFMEx (r0, r1, b2, b3) -> "SUBFMEx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ", " ^ string_of_bool b3 ^ ")" -| SUBFZEx (r0, r1, b2, b3) -> "SUBFZEx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_bool b2 ^ ", " ^ string_of_bool b3 ^ ")" -| SYNC -> "SYNC" -| TLBIA -> "TLBIA" -| TLBIE (r0) -> "TLBIE(" ^ string_of_eireg r0 ^ ")" -| TLBSYNC -> "TLBSYNC" -| TW (b0, r1, r2) -> "TW(" ^ string_of_bitstring b0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ")" -| TWI (b0, r1, i2) -> "TWI(" ^ string_of_bitstring b0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| XORx (r0, r1, r2, b3) -> "XORx(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_eireg r2 ^ ", " ^ string_of_bool b3 ^ ")" -| XORI (r0, r1, i2) -> "XORI(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| XORIS (r0, r1, i2) -> "XORIS(" ^ string_of_eireg r0 ^ ", " ^ string_of_eireg r1 ^ ", " ^ string_of_int i2 ^ ")" -| UNKNOWN (b0) -> "UNKNOWN(" ^ string_of_bitstring b0 ^ ")" - -let string_of_instr_list = string_of_list string_of_instr "\n" - -let string_of_instr_array = string_of_array string_of_instr "\n" diff --git a/checklink/PPC_types.ml b/checklink/PPC_types.ml deleted file mode 100644 index b3419db0..00000000 --- a/checklink/PPC_types.ml +++ /dev/null @@ -1,198 +0,0 @@ -open Library - -type eireg = int -type efreg = int - -type instr = -| ADDx of eireg * eireg * eireg * bool * bool -| ADDCx of eireg * eireg * eireg * bool * bool -| ADDEx of eireg * eireg * eireg * bool * bool -| ADDI of eireg * eireg * bitstring -| ADDIC of eireg * eireg * bitstring -| ADDIC_ of eireg * eireg * bitstring -| ADDIS of eireg * eireg * int -| ADDMEx of eireg * eireg * bool * bool -| ADDZEx of eireg * eireg * bool * bool -| ANDx of eireg * eireg * eireg * bool -| ANDCx of eireg * eireg * eireg * bool -| ANDI_ of eireg * eireg * int -| ANDIS_ of eireg * eireg * int -| Bx of bitstring * bool * bool -| BCx of bitstring * int * bitstring * bool * bool -| BCCTRx of bitstring * int * bool -| BCLRx of bitstring * int * bool -| CMP of int * bool * eireg * eireg -| CMPI of int * bool * eireg * bitstring -| CMPL of int * bool * eireg * eireg -| CMPLI of int * bool * eireg * int -| CNTLZWx of eireg * eireg * bool -| CRAND of int * int * int -| CRANDC of int * int * int -| CREQV of int * int * int -| CRNAND of int * int * int -| CRNOR of int * int * int -| CROR of int * int * int -| CRORC of int * int * int -| CRXOR of int * int * int -| DCBA of eireg * eireg -| DCBF of eireg * eireg -| DCBI of eireg * eireg -| DCBST of eireg * eireg -| DCBT of eireg * eireg -| DCBTST of eireg * eireg -| DCBZ of eireg * eireg -| DIVWx of eireg * eireg * eireg * bool * bool -| DIVWUx of eireg * eireg * eireg * bool * bool -| ECIWX of eireg * eireg * eireg -| ECOWX of eireg * eireg * eireg -| EIEIO -| EQVx of eireg * eireg * eireg * bool -| EXTSBx of eireg * eireg * bool -| EXTSHx of eireg * eireg * bool -| FABSx of efreg * efreg * bool -| FADDx of efreg * efreg * efreg * bool -| FADDSx of efreg * efreg * efreg * bool -| FCMPO of int * efreg * efreg -| FCMPU of int * efreg * efreg -| FCTIWx of efreg * efreg * bool -| FCTIWZx of efreg * efreg * bool -| FDIVx of efreg * efreg * efreg * bool -| FDIVSx of efreg * efreg * efreg * bool -| FMADDx of efreg * efreg * efreg * efreg * bool -| FMADDSx of efreg * efreg * efreg * efreg * bool -| FMRx of efreg * efreg * bool -| FMSUBx of efreg * efreg * efreg * efreg * bool -| FMSUBSx of efreg * efreg * efreg * efreg * bool -| FMULx of efreg * efreg * efreg * bool -| FMULSx of efreg * efreg * efreg * bool -| FNABSx of efreg * efreg * bool -| FNEGx of efreg * efreg * bool -| FNMADDx of efreg * efreg * efreg * efreg * bool -| FNMADDSx of efreg * efreg * efreg * efreg * bool -| FNMSUBx of efreg * efreg * efreg * efreg * bool -| FNMSUBSx of efreg * efreg * efreg * efreg * bool -| FRESx of efreg * efreg * bool -| FRSPx of efreg * efreg * bool -| FRSQRTEx of efreg * efreg * bool -| FSELx of efreg * efreg * efreg * efreg * bool -| FSQRTx of efreg * efreg * bool -| FSQRTSx of efreg * efreg * bool -| FSUBx of efreg * efreg * efreg * bool -| FSUBSx of efreg * efreg * efreg * bool -| ICBI of eireg * eireg -| ISYNC -| LBZ of eireg * eireg * bitstring -| LBZU of eireg * eireg * bitstring -| LBZUX of eireg * eireg * eireg -| LBZX of eireg * eireg * eireg -| LFD of efreg * eireg * bitstring -| LFDU of efreg * eireg * bitstring -| LFDUX of efreg * eireg * eireg -| LFDX of efreg * eireg * eireg -| LFS of efreg * eireg * bitstring -| LFSU of efreg * eireg * bitstring -| LFSUX of efreg * eireg * eireg -| LFSX of efreg * eireg * eireg -| LHA of eireg * eireg * bitstring -| LHAU of eireg * eireg * bitstring -| LHAUX of eireg * eireg * eireg -| LHAX of eireg * eireg * eireg -| LHBRX of eireg * eireg * eireg -| LHZ of eireg * eireg * bitstring -| LHZU of eireg * eireg * bitstring -| LHZUX of eireg * eireg * eireg -| LHZX of eireg * eireg * eireg -| LMW of eireg * eireg * int -| LSWI of eireg * eireg * eireg -| LSWX of eireg * eireg * eireg -| LWARX of eireg * eireg * eireg -| LWBRX of eireg * eireg * eireg -| LWZ of eireg * eireg * bitstring -| LWZU of eireg * eireg * bitstring -| LWZUX of eireg * eireg * eireg -| LWZX of eireg * eireg * eireg -| MCRF of int * int -| MCRFS of int * int -| MCRXR of int -| MFCR of eireg -| MFFSx of efreg * bool -| MFMSR of eireg -| MFSPR of eireg * bitstring -| MFSR of eireg * int -| MFSRIN of eireg * eireg -| MFTB of eireg * int -| MTCRF of eireg * int -| MTFSB0x of int * bool -| MTFSB1x of int * bool -| MTFSF of int * efreg * bool -| MTFSFIx of int * int * bool -| MTMSR of eireg -| MTSPR of eireg * bitstring -| MTSR of eireg * int -| MTSRIN of eireg * eireg -| MULHWx of eireg * eireg * eireg * bool -| MULHWUx of eireg * eireg * eireg * bool -| MULLI of eireg * eireg * bitstring -| MULLWx of eireg * eireg * eireg * bool * bool -| NANDx of eireg * eireg * eireg * bool -| NEGx of eireg * eireg * bool * bool -| NORx of eireg * eireg * eireg * bool -| ORx of eireg * eireg * eireg * bool -| ORCx of eireg * eireg * eireg * bool -| ORI of eireg * eireg * int -| ORIS of eireg * eireg * int -| RFI -| RLWIMIx of eireg * eireg * int * int * int * bool -| RLWINMx of eireg * eireg * int * int * int * bool -| RLWNMx of eireg * eireg * eireg * int * int * bool -| SC -| SLWx of eireg * eireg * eireg * bool -| SRAWx of eireg * eireg * eireg * bool -| SRAWIx of eireg * eireg * int * bool -| SRWx of eireg * eireg * eireg * bool -| STB of eireg * eireg * bitstring -| STBU of eireg * eireg * bitstring -| STBUX of eireg * eireg * eireg -| STBX of eireg * eireg * eireg -| STFD of efreg * eireg * bitstring -| STFDU of efreg * eireg * bitstring -| STFDUX of efreg * eireg * eireg -| STFDX of efreg * eireg * eireg -| STFIWX of eireg * eireg * eireg -| STFS of efreg * eireg * bitstring -| STFSU of efreg * eireg * bitstring -| STFSUX of efreg * eireg * eireg -| STFSX of efreg * eireg * eireg -| STH of eireg * eireg * bitstring -| STHBRX of eireg * eireg * eireg -| STHU of eireg * eireg * bitstring -| STHUX of eireg * eireg * eireg -| STHX of eireg * eireg * eireg -| STMW of eireg * eireg * int -| STSWI of eireg * eireg * eireg -| STSWX of eireg * eireg * eireg -| STW of eireg * eireg * bitstring -| STWBRX of eireg * eireg * eireg -| STWCX_ of eireg * eireg * eireg -| STWU of eireg * eireg * bitstring -| STWUX of eireg * eireg * eireg -| STWX of eireg * eireg * eireg -| SUBFx of eireg * eireg * eireg * bool * bool -| SUBFCx of eireg * eireg * eireg * bool * bool -| SUBFEx of eireg * eireg * eireg * bool * bool -| SUBFIC of eireg * eireg * bitstring -| SUBFMEx of eireg * eireg * bool * bool -| SUBFZEx of eireg * eireg * bool * bool -| SYNC -| TLBIA -| TLBIE of eireg -| TLBSYNC -| TW of bitstring * eireg * eireg -| TWI of bitstring * eireg * int -| XORx of eireg * eireg * eireg * bool -| XORI of eireg * eireg * int -| XORIS of eireg * eireg * int -| UNKNOWN of bitstring - -(* ELF parsed code *) -type ecode = instr list diff --git a/checklink/PPC_utils.ml b/checklink/PPC_utils.ml deleted file mode 100644 index 6c865dd0..00000000 --- a/checklink/PPC_utils.ml +++ /dev/null @@ -1,26 +0,0 @@ -open ELF_types -open ELF_utils -open Library -open PPC_parsers -open PPC_types - -let code_at_vaddr (e: elf)(vaddr: int32)(nb_instr: int): ecode option = - begin match bitstring_at_vaddr e vaddr (Safe32.of_int (4 * nb_instr)) with - | None -> None - | Some(code_bs, _, _) -> Some (parse_code_as_list code_bs) - end - -let code_of_sym (e: elf) (sym: elf32_sym): ecode option = - begin match bitstring_at_vaddr e sym.st_value sym.st_size with - | None -> None - | Some(bs, _, _) -> Some(parse_code_as_list bs) - end - -let code_of_sym_ndx (e: elf) (ndx: int): ecode option = - code_of_sym e e.e_symtab.(ndx) - -let code_of_sym_name (e: elf) (name: string): ecode option = - begin match ndx_of_sym_name e name with - | Some ndx -> code_of_sym_ndx e ndx - | None -> None - end diff --git a/checklink/Safe.ml b/checklink/Safe.ml deleted file mode 100644 index efcd3bd6..00000000 --- a/checklink/Safe.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* "Hacker's Delight", section 2.12 *) - -let ( + ) x y = - let z = x + y in - (* Overflow occurs iff x and y have same sign and z's sign is different *) - if (z lxor x) land (z lxor y) < 0 - then raise Exc.IntOverflow - else z - -let ( - ) x y = - let z = x - y in - (* Overflow occurs iff x and y have opposite signs and z and x have - opposite signs *) - if (x lxor y) land (z lxor x) < 0 - then raise Exc.IntOverflow - else z - -let ( * ) x y = - let z = x * y in - if (x = min_int && y < 0) || (y <> 0 && z / y <> x) - then raise Exc.IntOverflow - else z - -let of_int32 = Safe32.to_int -let to_int32 = Safe32.of_int diff --git a/checklink/Safe32.ml b/checklink/Safe32.ml deleted file mode 100644 index e72563d7..00000000 --- a/checklink/Safe32.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* "Hacker's Delight", section 2.12 *) - -let ( + ) x y = Int32.( - let z = add x y in - (* Overflow occurs iff x and y have same sign and z's sign is different *) - if logand (logxor z x) (logxor z y) < 0l - then raise Exc.Int32Overflow - else z -) - -let ( - ) x y = Int32.( - let z = sub x y in - (* Overflow occurs iff x and y have opposite signs and z and x have - opposite signs *) - if logand (logxor x y) (logxor z x) < 0l - then raise Exc.Int32Overflow - else z -) - -let ( * ) x y = Int32.( - let z = mul x y in - if (x = min_int && y < 0l) || (y <> 0l && div z y <> x) - then raise Exc.Int32Overflow - else z -) - -let to_int i32 = Int32.( - let i = to_int i32 in - if i32 = of_int i - then i - else raise Exc.IntOverflow -) - -let of_int = Int32.of_int diff --git a/checklink/Validator.ml b/checklink/Validator.ml deleted file mode 100644 index f9ca0edb..00000000 --- a/checklink/Validator.ml +++ /dev/null @@ -1,132 +0,0 @@ -open Check -open Disassembler -open ELF_parsers -open ELF_printers -open Fuzz - -let elf_file = ref (None: string option) -let sdump_files = ref ([] : string list) -let option_fuzz = ref false -let option_bytefuzz = ref false -let option_printelf = ref false - -let set_elf_file s = - begin match !elf_file with - | None -> elf_file := Some s - | Some _ -> raise (Arg.Bad "multiple ELF executables given on command line") - end - -let set_conf_file s = - begin match !conf_file with - | None -> conf_file := Some s - | Some _ -> raise (Arg.Bad "multiple configuration files given on command line") - end - -let read_sdumps_from_channel ic = - try - while true do - let l = input_line ic in - if l <> "" then sdump_files := l :: !sdump_files - done - with End_of_file -> - () - -let read_sdumps_from_file f = - if f = "-" then - read_sdumps_from_channel stdin - else begin - try - let ic = open_in f in - read_sdumps_from_channel ic; - close_in ic - with Sys_error msg -> - Printf.eprintf "Error reading file: %s\n" msg; exit 2 - end - -let option_disassemble = ref false -let disassemble_list = ref ([]: string list) -let add_disassemble s = - disassemble_list := s :: !disassemble_list; - option_disassemble := true - -let options = [ - (* Main options *) - "-exe", Arg.String set_elf_file, - "<filename> Specify the ELF executable file to analyze"; - "-conf", Arg.String set_conf_file, - "<filename> Specify a configuration file"; - "-files-from", Arg.String read_sdumps_from_file, - "<filename> Read names of .sdump files from the given file\n\ - \t(or from standard input if <filename> is '-')"; - (* Parsing behavior *) - "-relaxed", Arg.Set ELF_parsers.relaxed, - "Allows the following behaviors in the ELF parser:\n\ -\t* Use of a fallback heuristic to resolve symbols bootstrapped at load time"; - (* Printing behavior *) - "-no-exhaustive", Arg.Clear Check.exhaustivity, - "Disable the exhaustivity check of ELF function and data symbols"; - "-list-missing", Arg.Set Check.list_missing, - "List function and data symbols that were missing in the exhaustivity check"; - (* Alternative outputs *) - "-debug", Arg.Set Check.debug, - "Print a detailed trace of verification"; - "-disass", Arg.String add_disassemble, - "<symname> Disassemble the symbol with specified name (can be repeated)"; - "-print-elf", Arg.Set option_printelf, - "Print the contents of the unanalyzed ELF executable"; - (* ELF map related *) - "-print-elfmap", Arg.Set Check.print_elfmap, - "Print a map of the analyzed ELF executable"; - "-verbose-elfmap", Arg.Set Frameworks.verbose_elfmap, - "Show sections and symbols contained in the unknown parts of the elf map"; - (* Fuzz testing related *) - "-dump-elfmap", Arg.Set Check.dump_elfmap, - "Dump an ELF map to <exename>.elfmap, for use with random fuzzing"; - "-fuzz", Arg.Set option_fuzz, - "Random fuzz testing"; - "-fuzz-byte", Arg.Set option_bytefuzz, - "Random fuzz testing byte per byte"; - "-fuzz-debug", Arg.Set Fuzz.fuzz_debug, - "Print a detailed trace of ongoing fuzz testing"; -] - -let anonymous arg = - if Filename.check_suffix arg ".sdump" then - sdump_files := arg :: !sdump_files - else - set_elf_file arg - -let usage = - "The CompCert C post-linking validator, version " ^ Version.version ^ " -Usage: cchecklink [options] <.sdump files> <ELF executable> -In the absence of options, checks are performed and a short result is displayed. -Options are:" - -let _ = - Arg.parse options anonymous usage; - begin match !elf_file with - | None -> - Arg.usage options usage; - exit 2 - | Some elffilename -> - let sdumps = List.rev !sdump_files in - if !option_disassemble then begin - let elf = read_elf elffilename in - List.iter - (fun s -> - Printf.printf "Disassembling %s:\n%s\n\n" s (disassemble elf s) - ) - !disassemble_list - end else if !option_bytefuzz then begin - Random.self_init(); - fuzz_every_byte_loop elffilename sdumps - end else if !option_fuzz then begin - Random.self_init(); - fuzz_loop elffilename sdumps - end else if !option_printelf then begin - let elf = read_elf elffilename in - print_endline (string_of_elf elf) - end else begin - check_elf_dump elffilename sdumps - end - end diff --git a/common/Sections.ml b/common/Sections.ml index 0400bbc4..ec5b6412 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -27,10 +27,12 @@ type section_name = | Section_literal | Section_jumptable | Section_user of string * bool (*writable*) * bool (*executable*) - | Section_debug_info of string | Section_debug_abbrev + | Section_debug_info of string option | Section_debug_loc - | Section_debug_line of string + | Section_debug_line of string option + | Section_debug_ranges + | Section_debug_str type access_mode = | Access_default diff --git a/common/Sections.mli b/common/Sections.mli index 7a8c8225..8a13fb8a 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -26,10 +26,12 @@ type section_name = | Section_literal | Section_jumptable | Section_user of string * bool (*writable*) * bool (*executable*) - | Section_debug_info of string | Section_debug_abbrev + | Section_debug_info of string option | Section_debug_loc - | Section_debug_line of string + | Section_debug_line of string option + | Section_debug_ranges + | Section_debug_str type access_mode = | Access_default @@ -19,17 +19,16 @@ toolprefix='' target='' has_runtime_lib=true has_standard_headers=true -build_checklink=true advanced_debug=false usage='Usage: ./configure [options] target Supported targets: - ppc-linux (PowerPC, Linux) ppc-eabi (PowerPC, EABI with GNU/Unix tools) ppc-eabi-diab (PowerPC, EABI with Diab tools) - arm-linux (ARM, EABI) + ppc-linux (PowerPC, Linux) arm-eabi (ARM, EABI) + arm-linux (ARM, EABI) arm-eabihf (ARM, EABI using hardware FP registers) arm-hardfloat (ARM, EABI using hardware FP registers) ia32-linux (x86 32 bits, Linux) @@ -38,6 +37,10 @@ Supported targets: ia32-cygwin (x86 32 bits, Cygwin environment under Windows) manual (edit configuration file by hand) +For PowerPC targets, the "ppc-" prefix can be refined into: + ppc64- PowerPC 64 bits + e5500- Freescale e5500 core (PowerPC 64 bits + EREF extensions) + For ARM targets, the "arm-" prefix can be refined into: armv6- ARMv6 + VFPv2 armv7a- ARMv7-A + VFPv3-d16 (default) @@ -70,8 +73,6 @@ while : ; do has_runtime_lib=false;; -no-standard-headers) has_standard_headers=false;; - -no-checklink) - build_checklink=false;; *) if test -n "$target"; then echo "$usage" 1>&2; exit 2; fi target="$1";; @@ -81,46 +82,45 @@ done # Per-target configuration -cchecklink=false casmruntime="" asm_supports_cfi="" struct_passing="" struct_return="" case "$target" in - powerpc-linux|ppc-linux|powerpc-eabi|ppc-eabi) + powerpc-*|ppc-*|powerpc64-*|ppc64-*|e5500-*) arch="powerpc" - model="standard" + case "$target" in + powerpc64-*|ppc64-*) model="ppc64";; + e5500-*) model="e5500";; + *) model="ppc32";; + esac abi="eabi" struct_passing="ref-caller" case "$target" in *-linux) struct_return="ref";; - *-eabi) struct_return="int1-8";; + *) struct_return="int1-8";; esac - system="linux" - cc="${toolprefix}gcc" - cprepro="${toolprefix}gcc -std=c99 -U__GNUC__ -E" - casm="${toolprefix}gcc -c" - casmruntime="${toolprefix}gcc -c -Wa,-mregnames" - clinker="${toolprefix}gcc" - libmath="-lm" - cchecklink=${build_checklink} - advanced_debug=true;; - powerpc-eabi-diab|ppc-eabi-diab) - arch="powerpc" - model="standard" - abi="eabi" - struct_passing="ref-caller" - struct_return="int1-8" - system="diab" - cc="${toolprefix}dcc" - cprepro="${toolprefix}dcc -E -D__GNUC__" - casm="${toolprefix}das" - asm_supports_cfi=false - clinker="${toolprefix}dcc" - libmath="-lm" - cchecklink=${build_checklink} - advanced_debug=true;; + case "$target" in + *-eabi-diab) + system="diab" + cc="${toolprefix}dcc" + cprepro="${toolprefix}dcc -E -D__GNUC__" + casm="${toolprefix}das" + asm_supports_cfi=false + clinker="${toolprefix}dcc" + libmath="-lm" + advanced_debug=true;; + *) + system="linux" + cc="${toolprefix}gcc" + cprepro="${toolprefix}gcc -std=c99 -U__GNUC__ -E" + casm="${toolprefix}gcc -c" + casmruntime="${toolprefix}gcc -c -Wa,-mregnames" + clinker="${toolprefix}gcc" + libmath="-lm" + advanced_debug=true;; + esac;; arm*-*) arch="arm" case "$target" in @@ -320,20 +320,6 @@ if $missingtools; then exit 2 fi -# Additional packages needed for cchecklink - -if $cchecklink; then - echo "Testing availability of ocaml-bitstring... " | tr -d '\n' - if ocamlfind query bitstring > /dev/null - then - echo "yes" - else - echo "no" - echo "ocamlfind or ocaml-bitstring missing, cchecklink will not be built" - cchecklink=false - fi -fi - # Generate Makefile.config sharedir="$(dirname "$bindir")"/share @@ -363,7 +349,6 @@ CLINKER=$clinker LIBMATH=$libmath HAS_RUNTIME_LIB=$has_runtime_lib HAS_STANDARD_HEADERS=$has_standard_headers -CCHECKLINK=$cchecklink ASM_SUPPORTS_CFI=$asm_supports_cfi ADVANCED_DEBUG=$advanced_debug EOF @@ -377,7 +362,9 @@ cat >> Makefile.config <<'EOF' ARCH= # Hardware variant -# MODEL=standard # for PowerPC +# MODEL=ppc32 # for plain PowerPC +# MODEL=ppc64 # for PowerPC with 64-bit instructions +# MODEL=e5500 # for Freescale e5500 PowerPC variant # MODEL=armv6 # for ARM # MODEL=armv7a # for ARM # MODEL=armv7r # for ARM @@ -482,7 +469,6 @@ CompCert configuration: Library files installed in.... $libdirexp Standard headers provided..... $has_standard_headers Standard headers installed in. $libdirexp/include - cchecklink tool supported..... $cchecklink Build command to use.......... $make If anything above looks wrong, please edit file ./Makefile.config to correct. diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 074a0802..a86c779f 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -177,6 +177,48 @@ let remove_attributes_type env attr t = let erase_attributes_type env t = change_attributes_type env (fun a -> []) t +(* Remove all attributes from type that are not contained in attr *) +let strip_attributes_type t attr = + let strip = List.filter (fun a -> List.mem a attr) in + match t 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) + +(* Remove the last attribute from the toplevel and return the changed type *) +let strip_last_attribute typ = + let rec hd_opt l = match l with + [] -> None,[] + | a::rest -> Some a,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) + (* Extracting alignment value from a set of attributes. Return 0 if none. *) let alignas_attribute al = diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index ef1266d5..8b6c609b 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -56,6 +56,10 @@ val attr_is_type_related: attribute -> bool (* Is an attribute type-related (true) or variable-related (false)? *) val attr_inherited_by_members: attribute -> bool (* Is an attribute of a composite inherited by members of the composite? *) +val strip_attributes_type: typ -> attribute list -> typ + (* Remove all attributes from the given type that are not contained in the list *) +val strip_last_attribute: typ -> attribute option * typ + (* Remove the last top level attribute and return it *) (* Type compatibility *) diff --git a/debug/Debug.ml b/debug/Debug.ml index 21f8d9fd..87d04ad7 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -16,55 +16,51 @@ open C open Camlcoq open Dwarfgen open DwarfTypes +open Sections (* 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; + init: string -> unit; + atom_global: ident -> atom -> unit; + set_composite_size: ident -> struct_or_union -> int option -> unit; + set_member_offset: ident -> string -> int -> unit; + set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + insert_global_declaration: Env.t -> globdecl -> unit; + add_fun_addr: atom -> section_name -> (int * int) -> unit; + generate_debug_info: (atom -> string) -> string -> debug_entries option; + all_files_iter: (string -> unit) -> unit; + insert_local_declaration: storage -> ident -> typ -> location -> unit; + atom_local_variable: ident -> atom -> unit; + enter_scope: int -> int -> int -> unit; + enter_function_scope: int -> int -> unit; + add_lvar_scope: int -> ident -> int -> unit; + open_scope: atom -> int -> positive -> unit; + close_scope: atom -> int -> positive -> unit; + start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + end_live_range: (atom * atom) -> positive -> unit; + stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + add_label: atom -> positive -> int -> unit; + atom_parameter: ident -> ident -> atom -> unit; + compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; + compute_gnu_file_enum: (string -> unit) -> unit; + exists_section: section_name -> bool; + remove_unused: ident -> unit; + variable_printed: string -> unit; + add_diab_info: section_name -> int -> int -> int -> unit; } -let implem = +let default_implem = { init = (fun _ -> ()); - atom_function = (fun _ _ -> ()); - atom_global_variable = (fun _ _ -> ()); + atom_global = (fun _ _ -> ()); set_composite_size = (fun _ _ _ -> ()); set_member_offset = (fun _ _ _ -> ()); set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); - add_fun_addr = (fun _ _ -> ()); + add_fun_addr = (fun _ _ _ -> ()); generate_debug_info = (fun _ _ -> None); all_files_iter = (fun _ -> ()); insert_local_declaration = (fun _ _ _ _ -> ()); @@ -77,47 +73,42 @@ let implem = 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 _ _ -> ()); + 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 +let implem = ref default_implem + +let init_compile_unit name = !implem.init name +let atom_global id atom = !implem.atom_global 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 add_label atom p lbl = !implem.add_label atom p lbl +let atom_parameter fid pid atom = !implem.atom_parameter fid pid atom +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 line_start debug_info low_pc = !implem.add_diab_info sec line_start debug_info low_pc diff --git a/debug/Debug.mli b/debug/Debug.mli index aa702971..1585e7e4 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -15,54 +15,52 @@ open C open Camlcoq open DwarfTypes open BinNums +open Sections (* 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; + init: string -> unit; + atom_global: ident -> atom -> unit; + set_composite_size: ident -> struct_or_union -> int option -> unit; + set_member_offset: ident -> string -> int -> unit; + set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + insert_global_declaration: Env.t -> globdecl -> unit; + add_fun_addr: atom -> section_name -> (int * int) -> unit; + generate_debug_info: (atom -> string) -> string -> debug_entries option; + all_files_iter: (string -> unit) -> unit; + insert_local_declaration: storage -> ident -> typ -> location -> unit; + atom_local_variable: ident -> atom -> unit; + enter_scope: int -> int -> int -> unit; + enter_function_scope: int -> int -> unit; + add_lvar_scope: int -> ident -> int -> unit; + open_scope: atom -> int -> positive -> unit; + close_scope: atom -> int -> positive -> unit; + start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit; + end_live_range: (atom * atom) -> positive -> unit; + stack_variable: (atom * atom) -> int * int builtin_arg -> unit; + add_label: atom -> positive -> int -> unit; + atom_parameter: ident -> ident -> atom -> unit; + compute_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit; + compute_gnu_file_enum: (string -> unit) -> unit; + exists_section: section_name -> bool; + remove_unused: ident -> unit; + variable_printed: string -> unit; + add_diab_info: section_name -> int -> int -> int -> unit; } -val implem: implem +val default_implem: implem + +val implem: implem ref val init_compile_unit: string -> unit -val atom_function: ident -> atom -> unit -val atom_global_variable: ident -> atom -> unit +val atom_global: 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 add_fun_addr: atom -> section_name -> (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 @@ -74,15 +72,12 @@ 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_diab_file_enum: (section_name -> int) -> (string-> int) -> (unit -> unit) -> unit val compute_gnu_file_enum: (string -> unit) -> unit -val exists_section: string -> bool +val exists_section: section_name -> bool val remove_unused: ident -> unit val variable_printed: string -> unit -val add_diab_info: string -> (int * int * string) -> unit +val add_diab_info: section_name -> int -> int -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 9c5a92ba..51fbfde9 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -16,6 +16,7 @@ open C open Camlcoq open Cutil open DebugTypes +open Sections (* This implements an interface for the collection of debugging information. *) @@ -60,53 +61,7 @@ let typ_to_string (ty: typ) = 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) +let strip_attributes typ = strip_attributes_type typ [AConst; AVolatile] (* Find the type id to an type *) let find_type (ty: typ) = @@ -267,6 +222,7 @@ 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 +(* Various lookup functions for defintions *) let find_gvar_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in @@ -302,9 +258,6 @@ 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 @@ -476,20 +429,18 @@ let set_bitfield_offset str field offset underlying 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 = +let atom_global 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 + let id' = (Hashtbl.find stamp_to_definition id.stamp) in + let g = Hashtbl.find definitions id' in + match g with + | Function f -> + 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 + | GlobalVariable var -> + replace_var id' ({var with gvar_atom = Some atom;}) with Not_found -> () let atom_parameter fid id atom = @@ -509,8 +460,7 @@ let add_fun_addr atom (high,low) = 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 + replace_lvar id ({var with lvar_atom = Some atom;}) with Not_found -> () let add_lvar_scope f_id var_id s_id = @@ -582,21 +532,11 @@ 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 -> () @@ -611,7 +551,6 @@ let close_scope atom s_id lbl = | _ -> 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 -> () @@ -620,7 +559,6 @@ let start_live_range (f,v) lbl loc = 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 *) @@ -638,28 +576,39 @@ let end_live_range (f,v) lbl = 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 diab_additional: (string,int * int * section_name) Hashtbl.t = Hashtbl.create 7 + +let section_to_string = function + | Section_user (n,_,_) -> n + | _ -> ".text" let add_compilation_section_start sec addr = + let sec = section_to_string sec in Hashtbl.add compilation_section_start sec addr let add_compilation_section_end sec addr = + let sec = section_to_string sec in Hashtbl.add compilation_section_end sec addr -let add_diab_info sec addr = - Hashtbl.add diab_additional sec addr +let add_diab_info sec addr1 add2 addr3 = + let sec' = section_to_string sec in + Hashtbl.add compilation_section_start sec' addr3; + Hashtbl.add diab_additional sec' (addr1,add2,sec) + +let diab_add_fun_addr name _ addr = add_fun_addr name addr + +let gnu_add_fun_addr name sec (high,low) = + let sec = section_to_string sec in + if not (Hashtbl.mem compilation_section_start sec) then + Hashtbl.add compilation_section_start sec low; + Hashtbl.replace compilation_section_end sec high; + add_fun_addr name (high,low) let exists_section sec = - Hashtbl.mem compilation_section_start sec + Hashtbl.mem compilation_section_start (section_to_string sec) let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7 @@ -690,7 +639,6 @@ let init name = 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; @@ -701,4 +649,4 @@ let init name = Hashtbl.reset scope_ranges; Hashtbl.reset label_translation; all_files := StringSet.singleton name; - printed_vars := StringSet.empty; + printed_vars := StringSet.empty diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 1ab529df..455112ed 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -18,75 +18,51 @@ open Dwarfgen open DwarfTypes open Debug +let default_debug = + { + init = DebugInformation.init; + atom_global = DebugInformation.atom_global; + set_composite_size = DebugInformation.set_composite_size; + set_member_offset = DebugInformation.set_member_offset; + set_bitfield_offset = DebugInformation.set_bitfield_offset; + insert_global_declaration = DebugInformation.insert_global_declaration; + add_fun_addr = (fun _ _ _ -> ()); + generate_debug_info = (fun _ _ -> None); + all_files_iter = (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); + insert_local_declaration = DebugInformation.insert_local_declaration; + atom_local_variable = DebugInformation.atom_local_variable; + enter_scope = DebugInformation.enter_scope; + enter_function_scope = DebugInformation.enter_function_scope; + add_lvar_scope = DebugInformation.add_lvar_scope; + open_scope = DebugInformation.open_scope; + close_scope = DebugInformation.close_scope; + start_live_range = DebugInformation.start_live_range; + end_live_range = DebugInformation.end_live_range; + stack_variable = DebugInformation.stack_variable; + add_label = DebugInformation.add_label; + atom_parameter = DebugInformation.atom_parameter; + compute_diab_file_enum = DebugInformation.compute_diab_file_enum; + compute_gnu_file_enum = DebugInformation.compute_gnu_file_enum; + exists_section = DebugInformation.exists_section; + remove_unused = DebugInformation.remove_unused; + variable_printed = DebugInformation.variable_printed; + add_diab_info = (fun _ _ _ _ -> ()); + } + 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 + implem := + if Configuration.system = "diab" then + let gen = (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b)) in + Clflags.option_gdwarf := 2; (* Dwarf 2 is the only supported target *) + {default_debug with generate_debug_info = gen; + add_diab_info = DebugInformation.add_diab_info; + add_fun_addr = DebugInformation.diab_add_fun_addr;} + else + {default_debug with generate_debug_info = (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b)); + add_fun_addr = DebugInformation.gnu_add_fun_addr} 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 _ _ -> ()) + implem := default_implem let init () = if !Clflags.option_g && Configuration.advanced_debug then diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 8740d9c4..3e85ecfc 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -27,55 +27,77 @@ module DwarfPrinter(Target: DWARF_TARGET): open Target + let print_comment oc s = + if s <> "" then + fprintf oc " %s %s" comment s + + let string_of_comment s = sprintf " %s %s" comment s + + let add_comment buf s = + Buffer.add_string buf (sprintf " %s %s" comment s) + (* Byte value to string *) - let string_of_byte value = - sprintf " .byte %s\n" (if value then "0x1" else "0x0") + let string_of_byte value ct = + sprintf " .byte %s%s\n" (if value then "0x1" else "0x0") (string_of_comment ct) (* Print a label *) 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) + let add_byte buf value ct = + Buffer.add_string buf (string_of_byte value ct) + + let add_abbr_uleb v ct buf = + Buffer.add_string buf (sprintf " .uleb128 %d%s\n" v (string_of_comment ct)) - let add_abbr_uleb v buf = - Buffer.add_string buf (Printf.sprintf " .uleb128 %d\n" v) + let add_abbr_entry (v1,c1,v2) buf = + add_abbr_uleb v1 c1 buf; + let v2,c2 = code_of_dw_form v2 in + Buffer.add_string buf (sprintf " .uleb128 %d%s\n" v2 (string_of_comment c2)) - let add_abbr_entry (v1,v2) buf = - add_abbr_uleb v1 buf; - add_abbr_uleb v2 buf let add_file_loc buf = - let file,line = file_loc_type_abbr in - add_abbr_entry (0x3a,file) buf; - add_abbr_entry (0x3b,line) buf + add_abbr_entry (0x3a,"DW_AT_decl_file",DW_FORM_data4) buf; + add_abbr_entry (0x3b,"DW_AT_decl_line",DW_FORM_udata) buf - let add_type = add_abbr_entry (0x49,type_abbr) + let add_type = add_abbr_entry (0x49,"DW_AT_type",DW_FORM_ref_addr) - let add_name = add_abbr_entry (0x3,name_type_abbr) + let add_byte_size = add_abbr_entry (0x0b,"DW_AT_byte_size",DW_FORM_data1) - let add_byte_size = add_abbr_entry (0xb,byte_size_type_abbr) + let add_member_size = add_abbr_entry (0x0b,"DW_AT_byte_size",DW_FORM_udata) - let add_member_size = add_abbr_entry (0xb,member_size_abbr) + let add_high_pc = add_abbr_entry (0x12,"DW_AT_high_pc",DW_FORM_addr) - let add_high_pc = add_abbr_entry (0x12,high_pc_type_abbr) + let add_low_pc = add_abbr_entry (0x11,"DW_AT_low_pc",DW_FORM_addr) - let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) + let add_declaration = add_abbr_entry (0x3c,"DW_AT_declaration",DW_FORM_flag) - let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) + let add_string buf id c = function + | Simple_string _ -> add_abbr_entry (id,c,DW_FORM_string) buf + | Offset_string _ -> add_abbr_entry (id,c,DW_FORM_strp) buf + + let add_name buf = add_string buf 0x3 "DW_AT_name" + + let add_name_opt buf = function + | None -> () + | Some s -> add_name buf s let add_location loc buf = match loc with | None -> () - | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf + | Some (LocRef _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_data4) buf | Some (LocList _ ) | Some (LocSymbol _) - | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + | Some (LocSimple _) -> add_abbr_entry (0x2,"DW_AT_location",DW_FORM_block) buf + + let add_range buf = function + | Pc_pair _ -> + add_abbr_entry (0x11,"DW_AT_low_pc",DW_FORM_addr) buf; + add_abbr_entry (0x12,"DW_AT_high_pc",DW_FORM_addr) buf + | Offset _ -> + add_abbr_entry (0x55,"DW_AT_ranges",DW_FORM_data4) buf + | Empty -> () (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = @@ -84,130 +106,122 @@ module DwarfPrinter(Target: DWARF_TARGET): match v with | None -> () | Some _ -> f buf in - let prologue id = + let prologue id c = let has_child = match entity.children with | [] -> false | _ -> true in - add_abbr_uleb id buf; - add_byte buf has_child; - if has_sibling then add_abbr_entry (0x1,sibling_type_abbr) buf; + add_abbr_uleb id c buf; + add_byte buf has_child (if has_child then "DW_CHILDREN_yes" else "DW_CHILDREN_no"); + if has_sibling then add_abbr_entry (0x1,"DW_AT_sibling",DW_FORM_ref4) buf; in (match entity.tag with | DW_TAG_array_type e -> - prologue 0x1; - add_attr_some e.array_type_file_loc add_file_loc; + prologue 0x1 "DW_TAG_array_type"; add_type buf | DW_TAG_base_type b -> - prologue 0x24; + prologue 0x24 "DW_TAG_base_type"; add_byte_size buf; - add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,encoding_type_abbr)); - add_name buf + add_attr_some b.base_type_encoding (add_abbr_entry (0x3e,"DW_AT_encoding",DW_FORM_data1)); + add_name buf b.base_type_name; | DW_TAG_compile_unit e -> - prologue 0x11; - add_abbr_entry (0x1b,comp_dir_type_abbr) 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; - add_abbr_entry (0x10,stmt_list_type_abbr) buf; + prologue 0x11 "DW_TAG_compile_unit"; + add_string buf 0x1b "DW_AT_comp_dir" e.compile_unit_dir; + add_range buf e.compile_unit_range; + add_abbr_entry (0x13,"DW_AT_language",DW_FORM_udata) buf; + add_name buf e.compile_unit_name; + add_string buf 0x25 "DW_AT_producer" e.compile_unit_prod_name; + add_abbr_entry (0x10,"DW_AT_stmt_list",DW_FORM_data4) buf; | DW_TAG_const_type _ -> - prologue 0x26; + prologue 0x26 "DW_TAG_const_type"; add_type buf | DW_TAG_enumeration_type e -> - prologue 0x4; + prologue 0x4 "DW_TAG_enumeration_type"; add_attr_some e.enumeration_file_loc add_file_loc; add_byte_size buf; add_attr_some e.enumeration_declaration add_declaration; - add_attr_some e.enumeration_name add_name + add_name buf e.enumeration_name | DW_TAG_enumerator e -> - prologue 0x28; - add_attr_some e.enumerator_file_loc add_file_loc; - add_abbr_entry (0x1c,value_type_abbr) buf; - add_name buf + prologue 0x28 "DW_TAG_enumerator"; + add_abbr_entry (0x1c,"DW_AT_const_value",DW_FORM_sdata) buf; + add_name buf e.enumerator_name | DW_TAG_formal_parameter e -> - 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_attr_some e.formal_parameter_name add_name; + prologue 0x5 "DW_TAG_formal_parameter"; + add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,"DW_AT_artificial",DW_FORM_flag)); + add_name_opt buf e.formal_parameter_name; 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,"DW_AT_variable_parameter",DW_FORM_flag)); add_location e.formal_parameter_location buf - | DW_TAG_label _ -> - prologue 0xa; + | DW_TAG_label e -> + prologue 0xa "DW_TAG_label"; add_low_pc buf; - add_name buf; + add_name buf e.label_name; | DW_TAG_lexical_block a -> - prologue 0xb; - add_attr_some a.lexical_block_high_pc add_high_pc; - add_attr_some a.lexical_block_low_pc add_low_pc + prologue 0xb "DW_TAG_lexical_block"; + add_range buf a.lexical_block_range; | DW_TAG_member e -> - prologue 0xd; - add_attr_some e.member_file_loc add_file_loc; + prologue 0xd "DW_TAG_member"; 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_bit_offset (add_abbr_entry (0xc,"DW_AT_bit_offset",DW_FORM_data1)); + add_attr_some e.member_bit_size (add_abbr_entry (0xd,"DW_AT_bit_size",DW_FORM_data1)); add_attr_some e.member_declaration add_declaration; - add_attr_some e.member_name add_name; + add_name buf e.member_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) + | Some (DataLocBlock __) -> add_abbr_entry (0x38,"DW_AT_data_member_location",DW_FORM_block) buf + | Some (DataLocRef _) -> add_abbr_entry (0x38,"DW_AT_data_member_location",DW_FORM_ref4) buf) | DW_TAG_pointer_type _ -> - prologue 0xf; + prologue 0xf "DW_TAG_pointer_type"; add_type buf | DW_TAG_structure_type e -> - prologue 0x13; + prologue 0x13 "DW_TAG_structure_type"; add_attr_some e.structure_file_loc add_file_loc; add_attr_some e.structure_byte_size add_member_size; add_attr_some e.structure_declaration add_declaration; - add_attr_some e.structure_name add_name + add_name_opt buf e.structure_name | DW_TAG_subprogram e -> - prologue 0x2e; + prologue 0x2e "DW_TAG_subprogram"; add_file_loc buf; - add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); - 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_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); + add_range buf e.subprogram_range; + add_name buf e.subprogram_name; + add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf; add_attr_some e.subprogram_type add_type; | DW_TAG_subrange_type e -> - prologue 0x21; + prologue 0x21 "DW_TAG_subrange_type"; add_attr_some e.subrange_type add_type; (match e.subrange_upper_bound with | None -> () - | Some (BoundConst _) -> add_abbr_entry (0x2f,bound_const_type_abbr) buf - | Some (BoundRef _) -> add_abbr_entry (0x2f,bound_ref_type_abbr) buf) + | Some (BoundConst _) -> add_abbr_entry (0x2f,"DW_AT_upper_bound",DW_FORM_udata) buf + | Some (BoundRef _) -> add_abbr_entry (0x2f,"DW_AT_upper_bound",DW_FORM_ref4) buf) | DW_TAG_subroutine_type e -> - prologue 0x15; + prologue 0x15 "DW_TAG_subroutine_type"; add_attr_some e.subroutine_type add_type; - add_abbr_entry (0x27,prototyped_type_abbr) buf + add_abbr_entry (0x27,"DW_AT_prototyped",DW_FORM_flag) buf | DW_TAG_typedef e -> - prologue 0x16; + prologue 0x16 "DW_TAG_typedef"; add_attr_some e.typedef_file_loc add_file_loc; - add_name buf; + add_name buf e.typedef_name; add_type buf | DW_TAG_union_type e -> - prologue 0x17; + prologue 0x17 "DW_TAG_union_type"; add_attr_some e.union_file_loc add_file_loc; add_attr_some e.union_byte_size add_member_size; add_attr_some e.union_declaration add_declaration; - add_attr_some e.union_name add_name + add_name_opt buf e.union_name | DW_TAG_unspecified_parameter e -> - prologue 0x18; - add_attr_some e.unspecified_parameter_file_loc add_file_loc; - add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) + prologue 0x18 "DW_TAG_unspecified_parameter"; + add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,"DW_AT_artificial",DW_FORM_flag)) | DW_TAG_variable e -> - prologue 0x34; + prologue 0x34 "DW_TAG_variable"; 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_attr_some e.variable_external (add_abbr_entry (0x3f,"DW_AT_external",DW_FORM_flag)); + add_location e.variable_location buf; + add_name buf e.variable_name; add_type buf | DW_TAG_volatile_type _ -> - prologue 0x35; + prologue 0x35 "DW_TAG_volatile_type"; add_type buf); Buffer.contents buf @@ -248,16 +262,18 @@ module DwarfPrinter(Target: DWARF_TARGET): section oc Section_debug_abbrev; print_label oc !abbrev_start_addr; List.iter (fun (s,id) -> - fprintf oc " .uleb128 %d\n" id; + fprintf oc " .uleb128 %d%a\n" id print_comment "Abbreviation Code"; output_string oc s; - fprintf oc " .uleb128 0\n"; - fprintf oc " .uleb128 0\n\n") abbrevs; - fprintf oc " .sleb128 0\n" + fprintf oc " .uleb128 0%a\n" print_comment "EOM(1)"; + fprintf oc " .uleb128 0%a\n" print_comment "EOM(2)") abbrevs; + fprintf oc " .sleb128 0%a\n" print_comment "EOM(3)" let debug_start_addr = ref (-1) let debug_stmt_list = ref (-1) + let debug_ranges_addr = ref (-1) + let entry_labels: (int,int) Hashtbl.t = Hashtbl.create 7 (* Translate the ids to address labels *) @@ -280,116 +296,117 @@ module DwarfPrinter(Target: DWARF_TARGET): Hashtbl.add loc_labels id label; label - let print_loc_ref oc r = + let print_loc_ref oc c r = let ref = loc_to_label r in - fprintf oc " .4byte %a\n" label ref + fprintf oc " .4byte %a%a\n" label ref print_comment c (* Helper functions for debug printing *) - let print_opt_value oc o f = + let print_opt_value oc c o f = match o with | None -> () - | Some o -> f oc o + | Some o -> f oc c o - let print_flag oc b = - output_string oc (string_of_byte b) + let print_flag oc c b = + output_string oc (string_of_byte b c) - let print_string oc s = - fprintf oc " .asciz \"%s\"\n" s + let print_string oc c = function + | Simple_string s -> + fprintf oc " .asciz \"%s\"%a\n" s print_comment c + | Offset_string o -> print_loc_ref oc c o - let print_uleb128 oc d = - fprintf oc " .uleb128 %d\n" d + let print_uleb128 oc c d = + fprintf oc " .uleb128 %d%a\n" d print_comment c - let print_sleb128 oc d = - fprintf oc " .sleb128 %d\n" d + let print_sleb128 oc c d = + fprintf oc " .sleb128 %d%a\n" d print_comment c - let print_byte oc b = - fprintf oc " .byte 0x%X\n" b + let print_byte oc c b = + fprintf oc " .byte 0x%X%a\n" b print_comment c - let print_2byte oc b = - fprintf oc " .2byte 0x%X\n" b + let print_2byte oc c b = + fprintf oc " .2byte 0x%X%a\n" b print_comment c - let print_ref oc r = + let print_ref oc c r = let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref + fprintf oc " .4byte %a%a\n" label ref print_comment c let print_file_loc oc = function | Some (Diab_file_loc (file,col)) -> - fprintf oc " .4byte %a\n" label file; - print_uleb128 oc col + fprintf oc " .4byte %a%a\n" label file print_comment "DW_AT_decl_file"; + print_uleb128 oc "DW_AT_decl_line" col | Some (Gnu_file_loc (file,col)) -> - fprintf oc " .4byte %l\n" file; - print_uleb128 oc col + fprintf oc " .4byte %l%a\n" file print_comment "DW_AT_decl_file"; + print_uleb128 oc "DW_AT_decl_line" 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 + 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 + 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 + 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) + print_byte oc "" (dw_op_reg0 + i) else begin - print_byte oc dw_op_regx; - print_uleb128 oc i + print_byte oc "" dw_op_regx; + print_uleb128 oc "" i end - let print_loc oc loc = + let print_loc oc c loc = match loc with | LocSymbol s -> - print_sleb128 oc 5; - print_byte oc dw_op_addr; + print_sleb128 oc c 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_sleb128 oc c (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; + print_sleb128 oc "" size; List.iter (print_loc_expr oc) e - | LocRef f -> print_loc_ref oc f + | LocRef f -> print_loc_ref oc c f let print_list_loc oc = function | LocSymbol s -> - print_2byte oc 5; - print_byte oc dw_op_addr; + 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_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; + print_2byte oc "" size; List.iter (print_loc_expr oc) e - | LocRef f -> print_loc_ref oc f + | LocRef f -> print_loc_ref oc "" f - let print_data_location oc dl = + let print_data_location oc c dl = match dl with | DataLocBlock e -> - print_sleb128 oc (size_of_loc_expr e); + print_sleb128 oc c (size_of_loc_expr e); print_loc_expr oc e | _ -> () - let print_addr oc a = - fprintf oc " .4byte %a\n" label a + let print_addr oc c a = + fprintf oc " .4byte %a%a\n" label a print_comment c let print_array_type oc at = - print_file_loc oc at.array_type_file_loc; - print_ref oc at.array_type + print_ref oc "DW_AT_type" at.array_type - let print_bound_value oc = function - | BoundConst bc -> print_uleb128 oc bc - | BoundRef br -> print_ref oc br + let print_bound_value oc c = function + | BoundConst bc -> print_uleb128 oc c bc + | BoundRef br -> print_ref oc c br let print_base_type oc bt = - print_byte oc bt.base_type_byte_size; + print_byte oc "DW_AT_byte_size" bt.base_type_byte_size; (match bt.base_type_encoding with | Some e -> let encoding = match e with @@ -402,123 +419,114 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_ATE_unsigned -> 0x7 | DW_ATE_unsigned_char -> 0x8 in - print_byte oc encoding; + print_byte oc "DW_AT_encoding" encoding; | None -> ()); - print_string oc bt.base_type_name + print_string oc "DW_AT_name" bt.base_type_name + + let print_range oc = function + | Pc_pair (l,h) -> + print_addr oc "DW_AT_low_pc" l; + print_addr oc "DW_AT_high_pc" h + | Offset i -> fprintf oc " .4byte %a+0x%d%a\n" + label !debug_ranges_addr i print_comment "DW_AT_ranges" + | _ -> () let print_compilation_unit oc tag = - 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 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 !debug_stmt_list + print_string oc "DW_AT_comp_dir" tag.compile_unit_dir; + print_range oc tag.compile_unit_range; + print_uleb128 oc "DW_AT_language" 1; + print_string oc "DW_AT_name" tag.compile_unit_name; + print_string oc "DW_AT_producer" tag.compile_unit_prod_name; + print_addr oc "DW_AT_stmt_list" !debug_stmt_list let print_const_type oc ct = - print_ref oc ct.const_type + print_ref oc "DW_AT_type" ct.const_type let print_enumeration_type oc et = print_file_loc oc et.enumeration_file_loc; - print_uleb128 oc et.enumeration_byte_size; - print_opt_value oc et.enumeration_declaration print_flag; - print_opt_value oc et.enumeration_name print_string + print_uleb128 oc "DW_AT_byte_size" et.enumeration_byte_size; + print_opt_value oc "DW_AT_declaration" et.enumeration_declaration print_flag; + print_string oc "DW_AT_name" et.enumeration_name let print_enumerator oc en = - print_file_loc oc en.enumerator_file_loc; - print_sleb128 oc en.enumerator_value; - print_string oc en.enumerator_name + print_sleb128 oc "DW_AT_const_value" en.enumerator_value; + print_string oc "DW_AT_name" en.enumerator_name 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_name print_string; - 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_location print_loc + print_opt_value oc "DW_AT_artificial" fp.formal_parameter_artificial print_flag; + print_opt_value oc "DW_AT_name" fp.formal_parameter_name print_string; + print_ref oc "DW_AT_type" fp.formal_parameter_type; + print_opt_value oc "DW_AT_variable_parameter" fp.formal_parameter_variable_parameter print_flag; + print_opt_value oc "DW_AT_location" 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 + print_ref oc "DW_AT_low_pc" tl.label_low_pc; + print_string oc "DW_AT_name" tl.label_name let print_lexical_block oc lb = - print_opt_value oc lb.lexical_block_high_pc print_addr; - print_opt_value oc lb.lexical_block_low_pc print_addr + print_range oc lb.lexical_block_range 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_declaration print_flag; - print_opt_value oc mb.member_name print_string; - print_ref oc mb.member_type; - print_opt_value oc mb.member_data_member_location print_data_location + print_opt_value oc "DW_AT_byte_size" mb.member_byte_size print_byte; + print_opt_value oc "DW_AT_bit_offset" mb.member_bit_offset print_byte; + print_opt_value oc "DW_AT_bit_size" mb.member_bit_size print_byte; + print_opt_value oc "DW_AT_declaration" mb.member_declaration print_flag; + print_string oc "DW_AT_name" mb.member_name; + print_ref oc "DW_AT_type" mb.member_type; + print_opt_value oc "DW_AT_data_member_location" mb.member_data_member_location print_data_location let print_pointer oc pt = - print_ref oc pt.pointer_type + print_ref oc "DW_AT_type" pt.pointer_type let print_structure oc st = print_file_loc oc st.structure_file_loc; - print_opt_value oc st.structure_byte_size print_uleb128; - print_opt_value oc st.structure_declaration print_flag; - print_opt_value oc st.structure_name print_string + print_opt_value oc "DW_AT_byte_size" st.structure_byte_size print_uleb128; + print_opt_value oc "DW_AT_declaration" st.structure_declaration print_flag; + print_opt_value oc "DW_AT_name" st.structure_name print_string - let print_subprogram_addr oc (s,e) = - fprintf oc " .4byte %a\n" label e; - fprintf oc " .4byte %a\n" label s let print_subprogram oc sp = print_file_loc oc (Some sp.subprogram_file_loc); - print_opt_value oc sp.subprogram_external print_flag; - 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 + print_opt_value oc "DW_AT_external" sp.subprogram_external print_flag; + print_range oc sp.subprogram_range; + print_string oc "DW_AT_name" sp.subprogram_name; + print_flag oc "DW_AT_prototyped" sp.subprogram_prototyped; + print_opt_value oc "DW_AT_type" sp.subprogram_type print_ref let print_subrange oc sr = - print_opt_value oc sr.subrange_type print_ref; - print_opt_value oc sr.subrange_upper_bound print_bound_value + print_opt_value oc "DW_AT_type" sr.subrange_type print_ref; + print_opt_value oc "DW_AT_upper_bound" sr.subrange_upper_bound print_bound_value let print_subroutine oc st = - print_opt_value oc st.subroutine_type print_ref; - print_flag oc st.subroutine_prototyped + print_opt_value oc "DW_AT_type" st.subroutine_type print_ref; + print_flag oc "DW_AT_prototyped" st.subroutine_prototyped let print_typedef oc td = print_file_loc oc td.typedef_file_loc; - print_string oc td.typedef_name; - print_ref oc td.typedef_type + print_string oc "DW_AT_name" td.typedef_name; + print_ref oc "DW_AT_type" td.typedef_type let print_union_type oc ut = print_file_loc oc ut.union_file_loc; - print_opt_value oc ut.union_byte_size print_uleb128; - print_opt_value oc ut.union_declaration print_flag; - print_opt_value oc ut.union_name print_string + print_opt_value oc "DW_AT_byte_size" ut.union_byte_size print_uleb128; + print_opt_value oc "DW_AT_declaration" ut.union_declaration print_flag; + print_opt_value oc "DW_AT_name" ut.union_name print_string let print_unspecified_parameter oc up = - print_file_loc oc up.unspecified_parameter_file_loc; - print_opt_value oc up.unspecified_parameter_artificial print_flag + print_opt_value oc "DW_AT_artificial" up.unspecified_parameter_artificial print_flag let print_variable oc var = 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_ref oc var.variable_type + print_opt_value oc "DW_AT_declaration" var.variable_declaration print_flag; + print_opt_value oc "DW_AT_external" var.variable_external print_flag; + print_opt_value oc "DW_AT_location" var.variable_location print_loc; + print_string oc "DW_AT_name" var.variable_name; + print_ref oc "DW_AT_type" var.variable_type let print_volatile_type oc vt = - print_ref oc vt.volatile_type + print_ref oc "DW_AT_type" vt.volatile_type (* Print an debug entry *) let print_entry oc entry = @@ -528,11 +536,11 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> false | Some _ -> true in let id = get_abbrev entry has_sib in - print_sleb128 oc id; + print_sleb128 oc (sprintf "Abbrev [%d] %s" id (string_of_dw_tag entry.tag)) id; (match sib with | None -> () | Some s -> let lbl = entry_to_label s in - fprintf oc " .4byte %a-%a\n" label lbl label !debug_start_addr); + fprintf oc " .4byte %a-%a%a\n" label lbl label !debug_start_addr print_comment "DW_AT_sibling"); begin match entry.tag with | DW_TAG_array_type arr_type -> print_array_type oc arr_type @@ -557,12 +565,7 @@ module DwarfPrinter(Target: DWARF_TARGET): | DW_TAG_volatile_type vt -> print_volatile_type oc vt end) (fun e -> if e.children <> [] then - print_sleb128 oc 0) entry - - (* Print the debug abbrev section *) - let print_debug_abbrev oc entries = - List.iter (fun (_,_,_,e,_) -> compute_abbrev e) entries; - print_abbrev oc + print_sleb128 oc "End Of Children Mark" 0) entry (* Print the debug info section *) let print_debug_info oc start line_start entry = @@ -572,13 +575,13 @@ module DwarfPrinter(Target: DWARF_TARGET): 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; + fprintf oc " .4byte %a-%a%a\n" label debug_end label debug_length_start print_comment "Length of Unit"; print_label oc debug_length_start; - fprintf oc " .2byte 0x2\n"; (* Dwarf version *) - print_addr oc !abbrev_start_addr; (* Offset into the abbreviation *) - print_byte oc !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) + fprintf oc " .2byte 0x%d%a\n" !Clflags.option_gdwarf print_comment "DWARF version number"; (* Dwarf version *) + print_addr oc "Offset Into Abbrev. Section" !abbrev_start_addr; (* Offset into the abbreviation *) + print_byte oc "Address Size (in bytes)" !Machine.config.Machine.sizeof_ptr; (* Sizeof pointer type *) print_entry oc entry; - print_sleb128 oc 0; + print_sleb128 oc "" 0; print_label oc debug_end (* End of the debug section *) let print_location_entry oc c_low l = @@ -606,33 +609,61 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> print_location_entry_abs oc in List.iter f l + let list_opt l f = + match l with + | [] -> () + | _ -> f () + 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; + List.iter (fun e -> compute_abbrev e.entry) entries; + print_abbrev oc; + List.iter (fun e -> + let name = if e.section_name <> ".text" then Some e.section_name else None in + section oc (Section_debug_info name); + print_debug_info oc e.start_label e.line_label e.entry) entries; section oc Section_debug_loc; - List.iter (fun (_,_,_,_,l) -> print_location_list oc l) entries - - let print_gnu_entries oc cp loc = + List.iter (fun e -> print_location_list oc e.locs) entries + + let print_ranges oc r = + section oc Section_debug_ranges; + print_label oc !debug_ranges_addr; + List.iter (fun l -> + List.iter (fun (b,e) -> + fprintf oc " .4byte %a\n" label b; + fprintf oc " .4byte %a\n" label e) l; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n") r + + let print_gnu_entries oc cp (lpc,loc) s r = compute_abbrev cp; let line_start = new_label () and start = new_label () - and abbrev_start = new_label () in + and abbrev_start = new_label () + and range_label = new_label () in + debug_ranges_addr := range_label; abbrev_start_addr := abbrev_start; - section oc (Section_debug_info ""); + section oc (Section_debug_info None); 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 + list_opt loc (fun () -> + section oc Section_debug_loc; + print_location_list oc (lpc,loc)); + list_opt r (fun () -> + print_ranges oc r); + section oc (Section_debug_line None); + print_label oc line_start; + list_opt s (fun () -> + section oc Section_debug_str; + List.iter (fun (id,s) -> + print_label oc (loc_to_label id); + fprintf oc " .asciz \"%s\"\n" s) s) + (* Print the debug info and abbrev section *) let print_debug oc = function | Diab entries -> print_diab_entries oc entries - | Gnu (cp,loc) -> print_gnu_entries oc cp loc + | Gnu (cp,loc,s,r) -> print_gnu_entries oc cp loc s r end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 73588ad2..a4c75201 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -36,13 +36,11 @@ type encoding = type address = int -type block = string - 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 + | DW_OP_bregx of constant * int32 + | DW_OP_piece of constant + | DW_OP_reg of constant type location_value = | LocSymbol of atom @@ -58,30 +56,62 @@ type bound_value = | BoundConst of constant | BoundRef of reference -(* Types representing the attribute information per tag value *) +type string_const = + | Simple_string of string + | Offset_string of reference type file_loc = - | Diab_file_loc of int * constant - | Gnu_file_loc of int * constant + | Diab_file_loc of constant * constant + | Gnu_file_loc of constant * constant + +type dw_form = + | DW_FORM_addr + | DW_FORM_block2 + | DW_FORM_block4 + | DW_FORM_data2 + | DW_FORM_data4 + | DW_FORM_data8 + | DW_FORM_string + | DW_FORM_block + | DW_FORM_block1 + | DW_FORM_data1 + | DW_FORM_flag + | DW_FORM_sdata + | DW_FORM_strp + | DW_FORM_udata + | DW_FORM_ref_addr + | DW_FORM_ref1 + | DW_FORM_ref2 + | DW_FORM_ref4 + | DW_FORM_ref8 + | DW_FORM_ref_udata + | DW_FORM_ref_indirect + +type dw_range = + | Pc_pair of reference * reference (* Simple low,high pc *) + | Offset of constant (* DWARF 3 version for different range *) + | Empty (* Needed for compilation units only containing variables *) + +(* Types representing the attribute information per tag value *) type dw_tag_array_type = { - array_type_file_loc: file_loc option; array_type: reference; } type dw_tag_base_type = { base_type_byte_size: constant; - base_type_encoding: encoding option; - base_type_name: string; + base_type_encoding: encoding option; + base_type_name: string_const; } type dw_tag_compile_unit = { - compile_unit_name: string; - compile_unit_low_pc: int; - compile_unit_high_pc: int; + compile_unit_name: string_const; + compile_unit_range: dw_range; + compile_unit_dir: string_const; + compile_unit_prod_name: string_const; } type dw_tag_const_type = @@ -91,24 +121,22 @@ type dw_tag_const_type = type dw_tag_enumeration_type = { - enumeration_file_loc: file_loc option; + enumeration_file_loc: file_loc option; enumeration_byte_size: constant; - enumeration_declaration: flag option; - enumeration_name: string option; + enumeration_declaration: flag option; + enumeration_name: string_const; } type dw_tag_enumerator = { - enumerator_file_loc: file_loc option; enumerator_value: constant; - enumerator_name: string; + enumerator_name: string_const; } type dw_tag_formal_parameter = { - formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; - formal_parameter_name: string option; + formal_parameter_name: string_const option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; formal_parameter_location: location_value option; @@ -117,24 +145,22 @@ type dw_tag_formal_parameter = type dw_tag_label = { label_low_pc: address; - label_name: string; + label_name: string_const; } type dw_tag_lexical_block = { - lexical_block_high_pc: address option; - lexical_block_low_pc: address option; + lexical_block_range: dw_range; } type dw_tag_member = { - member_file_loc: file_loc option; member_byte_size: constant option; member_bit_offset: constant option; member_bit_size: constant option; member_data_member_location: data_location_value option; member_declaration: flag option; - member_name: string option; + member_name: string_const; member_type: reference; } @@ -145,21 +171,20 @@ type dw_tag_pointer_type = type dw_tag_structure_type = { - structure_file_loc: file_loc option; - structure_byte_size: constant option; - structure_declaration: flag option; - structure_name: string option; + structure_file_loc: file_loc option; + structure_byte_size: constant option; + structure_declaration: flag option; + structure_name: string_const option; } type dw_tag_subprogram = { subprogram_file_loc: file_loc; - subprogram_external: flag option; - subprogram_name: string; + subprogram_external: flag option; + subprogram_name: string_const; subprogram_prototyped: flag; - subprogram_type: reference option; - subprogram_high_pc: reference option; - subprogram_low_pc: reference option; + subprogram_type: reference option; + subprogram_range: dw_range; } type dw_tag_subrange_type = @@ -177,22 +202,21 @@ type dw_tag_subroutine_type = type dw_tag_typedef = { typedef_file_loc: file_loc option; - typedef_name: string; + typedef_name: string_const; typedef_type: reference; } type dw_tag_union_type = { - union_file_loc: file_loc option; - union_byte_size: constant option; - union_declaration: flag option; - union_name: string option; + union_file_loc: file_loc option; + union_byte_size: constant option; + union_declaration: flag option; + union_name: string_const option; } type dw_tag_unspecified_parameter = { - unspecified_parameter_file_loc: file_loc option; - unspecified_parameter_artificial: flag option; + unspecified_parameter_artificial: flag option; } type dw_tag_variable = @@ -200,7 +224,7 @@ type dw_tag_variable = variable_file_loc: file_loc; variable_declaration: flag option; variable_external: flag option; - variable_name: string; + variable_name: string_const; variable_type: reference; variable_location: location_value option; } @@ -244,14 +268,29 @@ type dw_entry = (* The type for the location list. *) type location_entry = { - loc: (int * int * location_value) list; + loc: (address * address * location_value) list; loc_id: reference; } -type dw_locations = int option * location_entry list +type dw_locations = constant option * location_entry list + +type range_entry = (address * address) list + +type dw_ranges = range_entry list + +type dw_string = (int * string) list + +type diab_entry = + { + section_name: string; + start_label: int; + line_label: int; + entry: dw_entry; + locs: dw_locations; + } -type diab_entries = (string * int * int * dw_entry * dw_locations) list +type diab_entries = diab_entry list -type gnu_entries = dw_entry * dw_locations +type gnu_entries = dw_entry * dw_locations * dw_string * dw_ranges type debug_entries = | Diab of diab_entries @@ -263,4 +302,5 @@ module type DWARF_TARGET= val label: out_channel -> int -> unit val section: out_channel -> section_name -> unit val symbol: out_channel -> atom -> unit + val comment: string end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 16e446ee..3e252dd2 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -53,6 +53,30 @@ let rec entry_fold f acc entry = let acc = f acc entry.tag in List.fold_left (entry_fold f) acc entry.children +(* Return the code and the corresponding comment for a DW_FORM *) +let code_of_dw_form = function + | DW_FORM_addr -> 0x01,"DW_FORM_addr" + | DW_FORM_block2 -> 0x03,"DW_FORM_block2" + | DW_FORM_block4 -> 0x04,"DW_FORM_block4" + | DW_FORM_data2 -> 0x05,"DW_FORM_data2" + | DW_FORM_data4 -> 0x06,"DW_FORM_data4" + | DW_FORM_data8 -> 0x07,"DW_FORM_data8" + | DW_FORM_string -> 0x08,"DW_FORM_string" + | DW_FORM_block -> 0x09,"DW_FORM_block" + | DW_FORM_block1 -> 0x0a,"DW_FORM_block1" + | DW_FORM_data1 -> 0x0b,"DW_FORM_data1" + | DW_FORM_flag -> 0x0c,"DW_FORM_flag" + | DW_FORM_sdata -> 0x0d,"DW_FORM_sdata" + | DW_FORM_strp -> 0x0e,"DW_FORM_strp" + | DW_FORM_udata -> 0x0f,"DW_FORM_udata" + | DW_FORM_ref_addr -> 0x10,"DW_FORM_ref_addr" + | DW_FORM_ref1 -> 0x11,"DW_FORM_ref1" + | DW_FORM_ref2 -> 0x12,"DW_FORM_ref2" + | DW_FORM_ref4 -> 0x13,"DW_FORM_ref4" + | DW_FORM_ref8 -> 0x14,"DW_FORM_ref8" + | DW_FORM_ref_udata -> 0x15,"DW_FORM_ref_udata" + | DW_FORM_ref_indirect -> 0x16,"DW_FORM_ref_indirect" + (* Attribute form encoding *) let dw_form_addr = 0x01 let dw_form_block2 = 0x03 @@ -84,35 +108,28 @@ let dw_op_regx = 0x90 let dw_op_bregx = 0x92 let dw_op_piece = 0x93 - -(* Default corresponding encoding for the different abbreviations *) -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 +(* Tag to string function *) +let string_of_dw_tag = function + | DW_TAG_array_type _ -> "DW_TAG_array_type" + | DW_TAG_compile_unit _ -> "DW_TAG_compile_unit" + | DW_TAG_base_type _ -> "DW_TAG_base_type" + | DW_TAG_const_type _ -> "DW_TAG_const_type" + | DW_TAG_enumeration_type _ -> "DW_TAG_enumeration_type" + | DW_TAG_enumerator _ -> "DW_TAG_enumerator" + | DW_TAG_formal_parameter _ -> "DW_TAG_formal_parameter" + | DW_TAG_label _ -> "DW_TAG_label" + | DW_TAG_lexical_block _ -> "DW_TAG_lexical_block" + | DW_TAG_member _ -> "DW_TAG_member" + | DW_TAG_pointer_type _ -> "DW_TAG_pointer_type" + | DW_TAG_structure_type _ -> "DW_TAG_structure_type" + | DW_TAG_subprogram _ -> "DW_TAG_subprogram" + | DW_TAG_subrange_type _ -> "DW_TAG_subrange_type" + | DW_TAG_subroutine_type _ -> "DW_TAG_subroutine_type" + | DW_TAG_typedef _ -> "DW_TAG_typedef" + | DW_TAG_union_type _ -> "DW_TAG_union_type" + | DW_TAG_unspecified_parameter _ -> "DW_TAG_unspecified_parameter" + | DW_TAG_variable _ -> "DW_TAG_variable" + | DW_TAG_volatile_type _ -> "DW_TAG_volatile_type" (* Sizeof functions for the encoding of uleb128 and sleb128 *) let sizeof_uleb128 value = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index ef0a6c4e..56a318fe 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -50,398 +50,483 @@ let rec mmap_opt f env = function | 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) +module type TARGET = + sig + val file_loc: string * int -> file_loc + val string_entry: string -> string_const + end -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) +type dwarf_accu = + { + typs: IntSet.t; + locs: location_entry list; + ranges: int * dw_ranges + } + +let (=<<) acc t = + {acc with typs = IntSet.add t acc.typs;} + +let (<=<) acc loc = + {acc with locs = loc@acc.locs;} + +let (>>=) acc r = + {acc with ranges = r;} + +let empty_accu = + { + typs = IntSet.empty; + locs = []; + ranges = 0,[] + } + +module Dwarfgenaux (Target: TARGET) = + struct + + include Target + + let name_opt n = if n <> "" then Some (string_entry n) else None + + (* 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 = string_entry (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 = string_entry (typ_to_string (TFloat (f.float_kind,[]))); + } in + new_entry id (DW_TAG_base_type float) -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 void_to_entry id = + let void = { + base_type_byte_size = 0; + base_type_encoding = None; + base_type_name = string_entry "void"; + } in + new_entry id (DW_TAG_base_type void) + + let file_loc_opt = function + | None -> None + | Some (f,l) -> + try + Some (file_loc (f,l)) + with Not_found -> None + + let typedef_to_entry id t = + let i = get_opt_val t.typ in + let td = { + typedef_file_loc = file_loc_opt t.typedef_file_loc; + typedef_name = string_entry 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 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; + let array_to_entry id arr = + let arr_tag = { + array_type = arr.arr_type; } 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))),[] + 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 id e = + let enumerator_to_entry e = + let tag = + { + enumerator_value = Int64.to_int (e.enumerator_const); + enumerator_name = string_entry 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 e.enum_file_loc; + enumeration_byte_size = bs; + enumeration_declaration = Some false; + enumeration_name = string_entry 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_artificial = None; + } in + [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] 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) + List.map (fun p -> + let fp = { + formal_parameter_artificial = None; + formal_parameter_name = name_opt p.param_name; + 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_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 = string_entry mem.cfd_name; + member_type = mem.cfd_typ; + } in + new_entry (next_id ()) (DW_TAG_member mem) + + let struct_to_entry id s = + let tag = { + structure_file_loc = file_loc_opt 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 = name_opt s.ct_name; + } 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 id s = + let tag = { + union_file_loc = file_loc_opt 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 = name_opt s.ct_name; + } 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 id s = + match s.ct_sou with + | Struct -> struct_to_entry id s + | Union -> union_to_entry id s + + let infotype_to_entry 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 id c + | EnumType e -> enum_to_entry id e + | FunctionType f -> fun_type_to_entry id f + | Typedef t -> typedef_to_entry 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 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 id t)::acc + else + acc) types []) -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 global_variable_to_entry 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.lvar_file_loc; - variable_declaration = None; - variable_external = None; - variable_name = v.lvar_name; - variable_type = v.lvar_type; + variable_file_loc = file_loc v.gvar_file_loc; + variable_declaration = Some v.gvar_declaration; + variable_external = Some v.gvar_external; + variable_name = string_entry v.gvar_name; + variable_type = v.gvar_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 + let acc = acc =<< v.gvar_type in + new_entry id (DW_TAG_variable var),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 p = + let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in + let p = { + formal_parameter_artificial = None; + formal_parameter_name = name_opt p.parameter_name; + formal_parameter_type = p.parameter_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = loc; + } in + let acc = (acc =<< p.formal_parameter_type) <=< loc_list in + new_entry (next_id ()) (DW_TAG_formal_parameter p),acc + + let scope_range f_id id (o,dwr) = + try + let r = Hashtbl.find scope_ranges id in + let lbl l h = match l,h with + | Some l,Some h-> + let l = (Hashtbl.find label_translation (f_id,l)) + and h = (Hashtbl.find label_translation (f_id,h)) in + l,h + | _ -> raise Not_found in + begin + match r with + | [] -> Empty,(o,dwr) + | [a] -> + let l,h = lbl a.start_addr a.end_addr in + Pc_pair (l,h),(o,dwr) + | a::rest -> + if !Clflags.option_gdwarf > 2 then + let r = List.map (fun e -> lbl e.start_addr e.end_addr) r in + (Offset o), (o + 2 + 4 * (List.length r),r::dwr) + else + let l,h = lbl (List.hd (List.rev rest)).start_addr a.end_addr in + Pc_pair (l,h),(o,dwr) + end + with Not_found -> Empty,(o,dwr) + + let rec local_variable_to_entry f_id acc v id = + match v.lvar_atom with + | None -> None,acc + | Some loc -> + let loc,loc_list = location_entry f_id loc in + let var = { + variable_file_loc = file_loc v.lvar_file_loc; + variable_declaration = None; + variable_external = None; + variable_name = string_entry v.lvar_name; + variable_type = v.lvar_type; + variable_location = loc; + } in + let acc = (acc =<< v.lvar_type) <=< loc_list in + Some (new_entry id (DW_TAG_variable var)),acc + + and scope_to_entry f_id acc sc id = + let r,dwr = scope_range f_id id acc.ranges in + let scope = { + lexical_block_range = r; + } in + let vars,acc = mmap_opt (local_to_entry f_id) acc sc.scope_variables in + let entry = new_entry id (DW_TAG_lexical_block scope) in + add_children entry vars,(acc >>= dwr) + + and local_to_entry f_id acc id = + match Hashtbl.find local_variables id with + | LocalVariable v -> local_variable_to_entry f_id acc v id + | Scope v -> let s,acc = (scope_to_entry f_id acc v id) in + Some s,acc + + let fun_scope_to_entries 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 f_id) acc sc.scope_variables + | _ -> assert false) + + let function_to_entry acc id f = + let r = match f.fun_low_pc, f.fun_high_pc with + | Some l,Some h -> Pc_pair (l,h) + | _ -> Empty in + let f_tag = { + subprogram_file_loc = file_loc f.fun_file_loc; + subprogram_external = Some f.fun_external; + subprogram_name = string_entry f.fun_name; + subprogram_prototyped = true; + subprogram_type = f.fun_return_type; + subprogram_range = r; + } in + let f_id = get_opt_val f.fun_atom in + let acc = match f.fun_return_type with Some s -> acc =<< s | None -> acc in + let f_entry = new_entry id (DW_TAG_subprogram f_tag) in + let params,acc = mmap (function_parameter_to_entry f_id) acc f.fun_parameter in + let vars,acc = fun_scope_to_entries f_id acc f.fun_scope in + add_children f_entry (params@vars),acc + + let definition_to_entry acc id t = + match t with + | GlobalVariable g -> global_variable_to_entry acc id g + | Function f -> function_to_entry acc id f + + end module StringMap = Map.Make(String) let diab_file_loc sec (f,l) = Diab_file_loc (Hashtbl.find filenum (sec,f),l) +let prod_name = + let version_string = + if Version.buildnr <> "" && Version.tag <> "" then + Printf.sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + else + Version.version in + Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" + version_string Configuration.arch Configuration.system Configuration.abi Configuration.model + +let diab_gen_compilation_section s defs acc = + let module Gen = Dwarfgenaux(struct + let file_loc = diab_file_loc s + let string_entry s = Simple_string s + end) in + let defs,accu = List.fold_left (fun (acc,bcc) (id,t) -> + let t,bcc = Gen.definition_to_entry bcc id t in + t::acc,bcc) ([],empty_accu) 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 = Simple_string !file_name; + compile_unit_range = Pc_pair (low_pc,high_pc); + compile_unit_dir = Simple_string (Sys.getcwd ()); + compile_unit_prod_name = Simple_string prod_name + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + let cp = add_children cp ((Gen.gen_types accu.typs) @ defs) in + { + section_name = s; + start_label = debug_start; + line_label = line_start; + entry = cp; + locs = Some low_pc,accu.locs; + }::acc + let gen_diab_debug_info sec_name var_section : debug_entries = let defs = Hashtbl.fold (fun id t acc -> let s = match t with @@ -449,42 +534,60 @@ let gen_diab_debug_info sec_name var_section : debug_entries = | 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 + let entries = StringMap.fold diab_gen_compilation_section defs [] in Diab entries let gnu_file_loc (f,l) = - Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) + Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l)) + +let string_table: (string,int) Hashtbl.t = Hashtbl.create 7 + +let gnu_string_entry s = + if String.length s < 4 || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str seciton *) + Simple_string s + else + try + Offset_string (Hashtbl.find string_table s) + with Not_found -> + let id = next_id () in + Hashtbl.add string_table s id; + Offset_string id + 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 r,dwr,low_pc = + try if !Clflags.option_gdwarf > 3 then + let pcs = Hashtbl.fold (fun s low acc -> + (low,Hashtbl.find compilation_section_end s)::acc) compilation_section_start [] in + match pcs with + | [] -> Empty,(0,[]),None + | [(l,h)] -> Pc_pair (l,h),(0,[]),Some l + | _ -> Offset 0,(2 + 4 * (List.length pcs),[pcs]),None + else + let l = Hashtbl.find compilation_section_start ".text" + and h = Hashtbl.find compilation_section_end ".text" in + Pc_pair(l,h),(0,[]),Some l + with Not_found -> Empty,(0,[]),None in + let accu = empty_accu >>= dwr in + let module Gen = Dwarfgenaux (struct + let file_loc = gnu_file_loc + let string_entry = gnu_string_entry + end) in + let defs,accu,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 t,bcc = Gen.definition_to_entry bcc id t in + t::acc,bcc,StringSet.add s sec) definitions ([],accu,StringSet.empty) in + let types = Gen.gen_types accu.typs in let cp = { - compile_unit_name = !file_name; - compile_unit_low_pc = low_pc; - compile_unit_high_pc = high_pc; + compile_unit_name = gnu_string_entry !file_name; + compile_unit_range = r; + compile_unit_dir = gnu_string_entry (Sys.getcwd ()); + compile_unit_prod_name = gnu_string_entry prod_name; } 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)) + let loc_pc = if StringSet.cardinal sec > 1 then None else low_pc in + let string_table = Hashtbl.fold (fun s i acc -> (i,s)::acc) string_table [] in + Gnu (cp,(loc_pc,accu.locs),string_table,snd accu.ranges) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 9d3697bd..b0c24f08 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -46,6 +46,7 @@ let option_dmach = ref false let option_dasm = ref false let option_sdump = ref false let option_g = ref false +let option_gdwarf = ref 2 let option_o = ref (None: string option) let option_E = ref false let option_S = ref false diff --git a/driver/Driver.ml b/driver/Driver.ml index 4b58fb4d..8fe6b07d 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -144,17 +144,7 @@ let parse_c_file sourcename ifile = end; csyntax,None -(* Dump Asm code in binary format for the validator *) - -let sdump_magic_number = "CompCertSDUMP" ^ Version.version - -let dump_asm asm destfile = - let oc = open_out_bin destfile in - output_string oc sdump_magic_number; - output_value oc asm; - output_value oc Camlcoq.string_of_atom; - output_value oc C2C.decl_atom; - close_out oc +(* Dump Asm code in asm format for the validator *) let jdump_magic_number = "CompCertJDUMP" ^ Version.version @@ -190,10 +180,7 @@ let compile_c_ast sourcename csyntax ofile debug = exit 2 in (* Dump Asm in binary and JSON format *) if !option_sdump then - begin - dump_asm asm (output_filename sourcename ".c" ".sdump"); - dump_jasm asm (output_filename sourcename ".c" ".json") - end; + dump_jasm asm (output_filename sourcename ".c" ".json"); (* Print Asm in text form *) let oc = open_out ofile in PrintAsm.print_program oc asm debug; @@ -444,6 +431,7 @@ Language support options (use -fno-<opt> to turn off -f<opt>) : -fnone Turn off all language support options above Debugging options: -g Generate debugging information + -gdwarf- (GCC only) Generate debug information in DWARF v2 or DWARF v3 -frename-static Rename static functions and declarations Optimization options: (use -fno-<opt> to turn off -f<opt>) -O Optimize the compiled code [on by default] @@ -549,7 +537,12 @@ let cmdline_actions = Exact "-fall", Self (fun _ -> set_all language_support_options); Exact "-fnone", Self (fun _ -> unset_all language_support_options); (* Debugging options *) - Exact "-g", Self (fun s -> option_g := true); + Exact "-g", Self (fun s -> option_g := true; + option_gdwarf := 3); + Exact "-gdwarf-2", Self (fun s -> option_g:=true; + option_gdwarf := 2); + Exact "-gdwarf-3", Self (fun s -> option_g := true; + option_gdwarf := 3); Exact "-frename-static", Self (fun s -> option_rename_static:= true); (* Code generation options -- more below *) Exact "-O0", Self (fun _ -> unset_all optimization_options); diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml index d11d9d23..dcea9de4 100644 --- a/ia32/Asmexpand.ml +++ b/ia32/Asmexpand.ml @@ -33,7 +33,7 @@ let _4 = coqint_of_camlint 4l let _8 = coqint_of_camlint 8l let stack_alignment () = - if Configuration.system = "macoxs" then 16 + if Configuration.system = "macosx" then 16 else 8 (* SP adjustment to allocate or free a stack frame *) diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index fe2c2998..84ddb134 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -105,7 +105,9 @@ module Cygwin_System : SYSTEM = | 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 *) + | Section_debug_abbrev -> ".section .debug_abbrev,\"dr\"" + | Section_debug_ranges -> ".section .debug_ranges,\"dr\"" + | Section_debug_str-> assert false (* Should not be used *) let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) @@ -157,6 +159,8 @@ module ELF_System : SYSTEM = | Section_debug_loc -> ".section .debug_loc,\"\",@progbits" | Section_debug_line _ -> ".section .debug_line,\"\",@progbits" | Section_debug_abbrev -> ".section .debug_abbrev,\"\",@progbits" + | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1" let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) @@ -210,7 +214,9 @@ module MacOS_System : SYSTEM = | 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 *) + | Section_debug_str -> ".section __DWARF,__debug_str,regular,debug" + | Section_debug_ranges -> ".section __DWARF,__debug_ranges,regular,debug" + | Section_debug_abbrev -> ".section __DWARF,__debug_abbrev,regular,debug" let stack_alignment = 16 (* mandatory *) @@ -656,13 +662,13 @@ module Target(System: SYSTEM):TARGET = begin match ef with | EF_annot(txt, targs) -> fprintf oc "%s annotation: " comment; - print_annot_text preg "%esp" oc (camlstring_of_coqstring txt) args + print_annot_text preg "%esp" oc (extern_atom txt) args | EF_debug(kind, txt, targs) -> print_debug_info comment print_file_line preg "%esp" oc (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg oc (extern_atom txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false @@ -753,9 +759,6 @@ module Target(System: SYSTEM):TARGET = 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 @@ -775,11 +778,8 @@ module Target(System: SYSTEM):TARGET = end; 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 diff --git a/powerpc/Archi.v b/powerpc/Archi.v index dbf24875..8ff11f08 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -43,3 +43,7 @@ Global Opaque big_endian default_pl_64 choose_binop_pl_64 default_pl_32 choose_binop_pl_32 float_of_single_preserves_sNaN. + +(** Can we use the 64-bit extensions to the PowerPC architecture? *) +Parameter ppc64: bool. + diff --git a/powerpc/Asm.v b/powerpc/Asm.v index ce306f73..228977c2 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -178,13 +178,19 @@ Inductive instruction : Type := | Peqv: ireg -> ireg -> ireg -> instruction (**r bitwise not-xor *) | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) + | Pextsw: ireg -> ireg -> instruction (**r 64-bit sign extension (PPC64) *) | Pfreeframe: Z -> int -> instruction (**r deallocate stack frame and restore previous frame (pseudo) *) | Pfabs: freg -> freg -> instruction (**r float absolute value *) | Pfabss: freg -> freg -> instruction (**r float absolute value *) | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) | Pfadds: freg -> freg -> freg -> instruction (**r float addition *) | Pfcmpu: freg -> freg -> instruction (**r float comparison *) + | Pfcfi: freg -> ireg -> instruction (**r signed-int-to-float conversion (pseudo, PPC64) *) + | Pfcfiu: freg -> ireg -> instruction (**r unsigned-int-to-float conversion (pseudo, PPC64) *) + | Pfcfid: freg -> freg -> instruction (**r signed-long-to-float conversion (PPC64) *) | Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion, round towards 0 (pseudo) *) + | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion, round towards 0 (pseudo, PPC64) *) + | Pfctidz: freg -> freg -> instruction (**r float-to-signed-long conversion, round towards 0 (PPC64) *) | Pfctiw: freg -> freg -> instruction (**r float-to-signed-int conversion, round by default *) | Pfctiwz: freg -> freg -> instruction (**r float-to-signed-int conversion, round towards 0 *) | Pfdiv: freg -> freg -> freg -> instruction (**r float division *) @@ -252,6 +258,7 @@ Inductive instruction : Type := | Porc: ireg -> ireg -> ireg -> instruction (**r bitwise or-complement *) | Pori: ireg -> ireg -> constant -> instruction (**r or with immediate *) | Poris: ireg -> ireg -> constant -> instruction (**r or with immediate high *) + | Prldicl: ireg -> ireg -> int -> int -> instruction (**r rotate and mask left (PPC64) *) | Prlwinm: ireg -> ireg -> int -> int -> instruction (**r rotate and mask *) | Prlwimi: ireg -> ireg -> int -> int -> instruction (**r rotate and insert *) | Pslw: ireg -> ireg -> ireg -> instruction (**r shift left *) @@ -260,6 +267,7 @@ Inductive instruction : Type := | Psrw: ireg -> ireg -> ireg -> instruction (**r shift right unsigned *) | Pstb: ireg -> constant -> ireg -> instruction (**r store 8-bit int *) | Pstbx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Pstdu: ireg -> constant -> ireg -> instruction (**r store 64-bit integer with update (PPC64) *) | Pstfd: freg -> constant -> ireg -> instruction (**r store 64-bit float *) | Pstfdu: freg -> constant -> ireg -> instruction (**r store 64-bit float with update *) | Pstfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) @@ -716,8 +724,14 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Val.addfs rs#r1 rs#r2))) m | Pfcmpu r1 r2 => Next (nextinstr (compare_float rs rs#r1 rs#r2)) m + | Pfcfi rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m + | Pfcfiu rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofintu rs#r1)))) m | Pfcti rd r1 => Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m + | Pfctiu rd r1 => + Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intuoffloat rs#r1)))) m | Pfdiv rd r1 r2 => Next (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m | Pfdivs rd r1 r2 => @@ -883,7 +897,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pdcbtst _ _ _ | Pdcbtls _ _ _ | Pdcbz _ _ + | Pextsw _ _ | Peieio + | Pfcfid _ _ + | Pfctidz _ _ | Pfctiw _ _ | Pfctiwz _ _ | Pfmadd _ _ _ _ @@ -907,6 +924,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmfcr _ | Pmfspr _ _ | Pmtspr _ _ + | Prldicl _ _ _ _ + | Pstdu _ _ _ | Pstwbrx _ _ _ | Pstwcx_ _ _ _ | Pstfdu _ _ _ diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index 888efff2..b8f08f22 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -188,13 +188,19 @@ let p_instruction oc ic = | Peqv (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Peqv\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pextsb (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pextsb\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 | Pextsh (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pextsh\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 + | Pextsw (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pextsw\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 | Pfreeframe (c,i) -> assert false (* Should not occur *) | Pfabs (fr1,fr2) | Pfabss (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfabs\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 | Pfadd (fr1,fr2,fr3) -> fprintf oc "{\"Instruction Name\":\"Pfadd\",\"Args\":[%a,%a,%a]}" p_freg fr1 p_freg fr2 p_freg fr3 | Pfadds (fr1,fr2,fr3) -> fprintf oc "{\"Instruction Name\":\"Pfadds\",\"Args\":[%a,%a,%a]}" p_freg fr1 p_freg fr2 p_freg fr3 | Pfcmpu (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfcmpu\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 + | Pfcfi (ir,fr) -> assert false (* Should not occur *) + | Pfcfid (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfcfid\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 + | Pfcfiu (ir,fr) -> assert false (* Should not occur *) | Pfcti (ir,fr) -> assert false (* Should not occur *) + | Pfctiu (ir,fr) -> assert false (* Should not occur *) + | Pfctidz (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfctidz\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 | Pfctiw (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfctiw\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 | Pfctiwz (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfctiwz\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 | Pfdiv (fr1,fr2,fr3) -> fprintf oc "{\"Instruction Name\":\"Pfdiv\",\"Args\":[%a,%a,%a]}" p_freg fr1 p_freg fr2 p_freg fr3 @@ -263,6 +269,7 @@ let p_instruction oc ic = | Porc (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Porc\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pori (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Pori\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c | Poris (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Poris\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c + | Prldicl (ir1,ir2,ic1,ic2) -> fprintf oc "{\"Instruction Name\":\"Prldicl\",\"Args\":[%a,%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_int_constant ic1 p_int_constant ic2 | Prlwinm (ir1,ir2,ic1,ic2) -> fprintf oc "{\"Instruction Name\":\"Prlwinm\",\"Args\":[%a,%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_int_constant ic1 p_int_constant ic2 | Prlwimi (ir1,ir2,ic1,ic2) -> fprintf oc "{\"Instruction Name\":\"Prlwimi\",\"Args\":[%a,%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_int_constant ic1 p_int_constant ic2 | Pslw (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pslw\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 @@ -271,6 +278,7 @@ let p_instruction oc ic = | Psrw (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Psrw\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pstb (ir1,c,ir2) -> fprintf oc "{\"Instruction Name\":\"Pstb\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_constant c p_ireg ir2 | Pstbx (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pstbx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 + | Pstdu (ir1,c,ir2) -> fprintf oc "{\"Instruction Name\":\"Pstdu\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_constant c p_ireg ir2 | Pstfd (fr,c,ir) | Pstfd_a (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Pstfd\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir | Pstfdu (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Pstfdu\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir @@ -333,7 +341,9 @@ let p_section oc = function | Section_debug_info _ | Section_debug_abbrev | Section_debug_line _ - | Section_debug_loc -> () (* There should be no info in the debug sections *) + | Section_debug_loc + | Section_debug_ranges + | Section_debug_str -> () (* 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 c88f6b6d..161d12b7 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -23,6 +23,13 @@ open Asmexpandaux exception Error of string +(* FreeScale's EREF extensions *) + +let eref = + match Configuration.model with + | "e5500" -> true + | _ -> false + (* Useful constants and helper functions *) let _0 = Integers.Int.zero @@ -485,8 +492,24 @@ let expand_builtin_inline name args res = emit (Plwz (res, Cint! retaddr_offset,GPR1)) (* isel *) | "__builtin_isel", [BA (IR a1); BA (IR a2); BA (IR a3)],BR (IR res) -> - emit (Pcmpwi (a1,Cint (_0))); - emit (Pisel (res,a3,a2,CRbit_2)) + if eref then begin + emit (Pcmpwi (a1,Cint (Int.zero))); + emit (Pisel (res,a3,a2,CRbit_2)) + end else if a2 = a3 then + emit (Pmr (res, a2)) + else begin + (* a1 has type _Bool, hence it is 0 or 1 *) + emit (Psubfic (GPR0, a1, Cint _0)); + (* r0 = 0xFFFF_FFFF if a1 is true, r0 = 0 if a1 is false *) + if res <> a3 then begin + emit (Pand_ (res, a2, GPR0)); + emit (Pandc (GPR0, a3, GPR0)) + end else begin + emit (Pandc (res, a3, GPR0)); + emit (Pand_ (GPR0, a2, GPR0)) + 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)); @@ -598,6 +621,24 @@ let expand_instruction instr = emit (Paddi(GPR1, GPR1, Cint(coqint_of_camlint sz))) else emit (Plwz(GPR1, Cint ofs, GPR1)) + | Pfcfi(r1, r2) -> + assert (Archi.ppc64); + emit (Pextsw(GPR0, r2)); + emit (Pstdu(GPR0, Cint _m8, GPR1)); + emit (Pcfi_adjust _8); + emit (Plfd(r1, Cint _0, GPR1)); + emit (Pfcfid(r1, r1)); + emit (Paddi(GPR1, GPR1, Cint _8)); + emit (Pcfi_adjust _m8) + | Pfcfiu(r1, r2) -> + assert (Archi.ppc64); + emit (Prldicl(GPR0, r2, _0, coqint_of_camlint 32l)); + emit (Pstdu(GPR0, Cint _m8, GPR1)); + emit (Pcfi_adjust _8); + emit (Plfd(r1, Cint _0, GPR1)); + emit (Pfcfid(r1, r1)); + emit (Paddi(GPR1, GPR1, Cint _8)); + emit (Pcfi_adjust _m8) | Pfcti(r1, r2) -> emit (Pfctiwz(FPR13, r2)); emit (Pstfdu(FPR13, Cint _m8, GPR1)); @@ -605,6 +646,14 @@ let expand_instruction instr = emit (Plwz(r1, Cint _4, GPR1)); emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) + | Pfctiu(r1, r2) -> + assert (Archi.ppc64); + emit (Pfctidz(FPR13, r2)); + emit (Pstfdu(FPR13, Cint _m8, GPR1)); + emit (Pcfi_adjust _8); + emit (Plwz(r1, Cint _4, GPR1)); + emit (Paddi(GPR1, GPR1, Cint _8)); + emit (Pcfi_adjust _m8) | Pfmake(rd, r1, r2) -> emit (Pstwu(r1, Cint _m8, GPR1)); emit (Pcfi_adjust _8); @@ -670,7 +719,7 @@ let expand_function id fn = try set_current_function fn; if !Clflags.option_g then - expand_debug id 2 preg_to_dwarf expand_instruction fn.fn_code + expand_debug id 1 preg_to_dwarf expand_instruction fn.fn_code else List.iter expand_instruction fn.fn_code; Errors.OK (get_current_function ()) diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 6a027eee..4ad5e2f9 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -496,6 +496,15 @@ Definition transl_op | Ointoffloat, a1 :: nil => do r1 <- freg_of a1; do r <- ireg_of res; OK (Pfcti r r1 :: k) + | Ointuoffloat, a1 :: nil => + do r1 <- freg_of a1; do r <- ireg_of res; + OK (Pfctiu r r1 :: k) + | Ofloatofint, a1 :: nil => + do r1 <- ireg_of a1; do r <- freg_of res; + OK (Pfcfi r r1 :: k) + | Ofloatofintu, a1 :: nil => + do r1 <- ireg_of a1; do r <- freg_of res; + OK (Pfcfiu r r1 :: k) | Ofloatofwords, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- freg_of res; OK (Pfmake r r1 r2 :: k) diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 1981f1a7..aa2645f3 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -941,6 +941,18 @@ Opaque Val.add. replace v with (Val.maketotal (Val.intoffloat (rs x))). TranslOpSimpl. rewrite H1; auto. + (* Ointuoffloat *) + replace v with (Val.maketotal (Val.intuoffloat (rs x))). + TranslOpSimpl. + rewrite H1; auto. + (* Ofloatofint *) + replace v with (Val.maketotal (Val.floatofint (rs x))). + TranslOpSimpl. + rewrite H1; auto. + (* Ofloatofintu *) + replace v with (Val.maketotal (Val.floatofintu (rs x))). + TranslOpSimpl. + rewrite H1; auto. (* Ocmp *) destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto. exists rs'; auto with asmgen. diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v index a8aa94c5..fe209627 100644 --- a/powerpc/Machregs.v +++ b/powerpc/Machregs.v @@ -134,7 +134,7 @@ Definition destroyed_by_op (op: operation): list mreg := match op with | Ofloatconst _ => R12 :: nil | Osingleconst _ => R12 :: nil - | Ointoffloat => F13 :: nil + | Ointoffloat | Ointuoffloat => F13 :: nil | _ => nil end. diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v index 672bd6f2..4d8c32bd 100644 --- a/powerpc/NeedOp.v +++ b/powerpc/NeedOp.v @@ -56,7 +56,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) | Osingleoffloat | Ofloatofsingle => op1 (default nv) - | Ointoffloat => op1 (default nv) + | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv) | Ofloatofwords | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocmp c => needs_of_condition c diff --git a/powerpc/Op.v b/powerpc/Op.v index 18e285e1..c8028557 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -107,6 +107,9 @@ Inductive operation : Type := | Ofloatofsingle: operation (**r [rd] is [r1] extended to double-precision float *) (*c Conversions between int and float: *) | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *) + | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] (PPC64 only) *) + | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] (PPC64 only) *) + | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] (PPC64 only *) | Ofloatofwords: operation (**r [rd = float_of_words(r1,r2)] *) (*c Manipulating 64-bit integers: *) | Omakelong: operation (**r [rd = r1 << 32 | r2] *) @@ -231,6 +234,9 @@ Definition eval_operation | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 | Ofloatofwords, v1::v2::nil => Some(Val.floatofwords v1 v2) | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) | Olowlong, v1::nil => Some(Val.loword v1) @@ -332,6 +338,9 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) | Ofloatofwords => (Tint :: Tint :: nil, Tfloat) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -420,6 +429,9 @@ Proof with (try exact I). destruct v0... destruct v0... destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... + destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + destruct v0; simpl in H0; inv H0... + destruct v0; simpl in H0; inv H0... destruct v0; destruct v1... destruct v0; destruct v1... destruct v0... @@ -783,6 +795,10 @@ Proof. inv H4; simpl; auto. inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. exists (Vint i); auto. + inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + inv H4; simpl in H1; inv H1; simpl. TrivialExists. + inv H4; simpl in H1; inv H1; simpl. TrivialExists. inv H4; inv H2; simpl; auto. inv H4; inv H2; simpl; auto. inv H4; simpl; auto. diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index 6d39569e..a1fcecc7 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -466,19 +466,23 @@ Nondetfunction cast16signed (e: expr) := Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). Definition intuoffloat (e: expr) := - Elet e - (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) - (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) - (intoffloat (Eletvar 1)) - (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat. + if Archi.ppc64 then + Eop Ointuoffloat (e ::: Enil) + else + Elet e + (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) + (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) + (intoffloat (Eletvar 1)) + (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat. Nondetfunction floatofintu (e: expr) := match e with | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil | _ => - subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil)) - (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil) + if Archi.ppc64 then Eop Ofloatofintu (e ::: Enil) else + subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil)) + (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil) end. Nondetfunction floatofint (e: expr) := @@ -486,9 +490,10 @@ Nondetfunction floatofint (e: expr) := | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil | _ => - subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil - ::: addimm Float.ox8000_0000 e ::: Enil)) - (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil) + if Archi.ppc64 then Eop Ofloatofint (e ::: Enil) else + subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil + ::: addimm Float.ox8000_0000 e ::: Enil)) + (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil) end. Definition intofsingle (e: expr) := diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index b40ad21b..757f1fd0 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -875,6 +875,8 @@ Theorem eval_floatofint: Proof. intros until y. unfold floatofint. destruct (floatofint_match a); intros. InvEval. TrivialExists. + destruct Archi.ppc64. + TrivialExists. rename e0 into a. destruct x; simpl in H0; inv H0. exists (Vfloat (Float.of_int i)); split; auto. set (t1 := addimm Float.ox8000_0000 a). @@ -897,6 +899,8 @@ Theorem eval_floatofintu: Proof. intros until y. unfold floatofintu. destruct (floatofintu_match a); intros. InvEval. TrivialExists. + destruct Archi.ppc64. + TrivialExists. rename e0 into a. destruct x; simpl in H0; inv H0. exists (Vfloat (Float.of_intu i)); split; auto. unfold floatofintu. diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 74eb8776..73cb12f5 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -126,7 +126,9 @@ module Linux_System : SYSTEM = | 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" + | Section_debug_line _ -> ".section .debug_line,\"\",@progbits" + | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1" let section oc sec = @@ -150,20 +152,14 @@ module Linux_System : SYSTEM = 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 = 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 debug_section _ _ = () @@ -217,19 +213,26 @@ module Diab_System : SYSTEM = | true, false -> 'd' (* data *) | false, true -> 'c' (* text *) | false, false -> 'r') (* const *) - | Section_debug_info s -> sprintf ".section .debug_info%s,,n" (if s <> ".text" then s else "") + | Section_debug_info (Some s) -> + sprintf ".section .debug_info%s,,n" s + | Section_debug_info None -> + sprintf ".section .debug_info,,n" | 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 + | Section_debug_line (Some s) -> + sprintf ".section .debug_line.%s,,n\n" s + | Section_debug_line None -> + sprintf ".section .debug_line,,n\n" + | Section_debug_ranges + | Section_debug_str -> assert false (* Should not be used *) let section oc sec = let name = name_of_section sec in assert (name <> "COMM"); match sec with - | Section_debug_info s -> + | Section_debug_info (Some s) -> fprintf oc " %s\n" name; - if s <> ".text" then - fprintf oc " .sectionlink .debug_info\n" + fprintf oc " .sectionlink .debug_info\n" | _ -> fprintf oc " %s\n" name @@ -249,18 +252,19 @@ module Diab_System : SYSTEM = match sec with | Section_debug_abbrev | Section_debug_info _ + | Section_debug_str | 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 + if not (Debug.exists_section sec) 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; + Debug.add_diab_info sec line_start debug_info low_pc; let line_name = ".debug_line" ^(if name <> ".text" then name else "") in + section oc (Section_debug_line (if name <> ".text" then Some name else None)); fprintf oc " .section %s,,n\n" line_name; if name <> ".text" then fprintf oc " .sectionlink .debug_line\n"; @@ -279,7 +283,7 @@ module Diab_System : SYSTEM = let print_epilogue oc = let end_label sec = fprintf oc "\n"; - fprintf oc " %s\n" sec; + section oc sec; let label_end = new_label () in fprintf oc "%a:\n" label label_end; label_end @@ -484,6 +488,8 @@ module Target (System : SYSTEM):TARGET = fprintf oc " extsb %a, %a\n" ireg r1 ireg r2 | Pextsh(r1, r2) -> fprintf oc " extsh %a, %a\n" ireg r1 ireg r2 + | Pextsw(r1, r2) -> + fprintf oc " extsw %a, %a\n" ireg r1 ireg r2 | Pfreeframe(sz, ofs) -> assert false | Pfabs(r1, r2) | Pfabss(r1, r2) -> @@ -494,8 +500,18 @@ module Target (System : SYSTEM):TARGET = fprintf oc " fadds %a, %a, %a\n" freg r1 freg r2 freg r3 | Pfcmpu(r1, r2) -> fprintf oc " fcmpu %a, %a, %a\n" creg 0 freg r1 freg r2 + | Pfcfi(r1, r2) -> + assert false + | Pfcfid(r1, r2) -> + fprintf oc " fcfid %a, %a\n" freg r1 freg r2 + | Pfcfiu(r1, r2) -> + assert false | Pfcti(r1, r2) -> assert false + | Pfctidz(r1, r2) -> + fprintf oc " fctidz %a, %a\n" freg r1 freg r2 + | Pfctiu(r1, r2) -> + assert false | Pfctiw(r1, r2) -> fprintf oc " fctiw %a, %a\n" freg r1 freg r2 | Pfctiwz(r1, r2) -> @@ -628,6 +644,9 @@ module Target (System : SYSTEM):TARGET = fprintf oc " ori %a, %a, %a\n" ireg r1 ireg r2 constant c | Poris(r1, r2, c) -> fprintf oc " oris %a, %a, %a\n" ireg r1 ireg r2 constant c + | Prldicl(r1, r2, c1, c2) -> + fprintf oc " rldicl %a, %a, %ld, %ld\n" + ireg r1 ireg r2 (camlint_of_coqint c1) (camlint_of_coqint c2) | Prlwinm(r1, r2, c1, c2) -> let (mb, me) = rolm_mask (camlint_of_coqint c2) in fprintf oc " rlwinm %a, %a, %ld, %d, %d %s 0x%lx\n" @@ -650,6 +669,8 @@ module Target (System : SYSTEM):TARGET = fprintf oc " stb %a, %a(%a)\n" ireg r1 constant c ireg r2 | Pstbx(r1, r2, r3) -> fprintf oc " stbx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pstdu(r1, c, r2) -> + fprintf oc " stdu %a, %a(%a)\n" ireg r1 constant c ireg r2 | Pstfd(r1, c, r2) | Pstfd_a(r1, c, r2) -> fprintf oc " stfd %a, %a(%a)\n" freg r1 constant c ireg r2 | Pstfdu(r1, c, r2) -> @@ -768,7 +789,7 @@ module Target (System : SYSTEM):TARGET = let nlo = Int64.to_int32 n and nhi = Int64.to_int32(Int64.shift_right_logical n 32) in fprintf oc "%a: .long 0x%lx, 0x%lx\n" label lbl nhi nlo - + let print_literal32 oc (lbl, n) = fprintf oc "%a: .long 0x%lx\n" label lbl n diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v index 9985fb9f..fe5a0792 100644 --- a/powerpc/ValueAOp.v +++ b/powerpc/ValueAOp.v @@ -102,6 +102,9 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 + | Ointuoffloat, v1::nil => intuoffloat v1 + | Ofloatofint, v1::nil => floatofint v1 + | Ofloatofintu, v1::nil => floatofintu v1 | Ofloatofwords, v1::v2::nil => floatofwords v1 v2 | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 diff --git a/powerpc/extractionMachdep.v b/powerpc/extractionMachdep.v index b448e3d2..b0f05536 100644 --- a/powerpc/extractionMachdep.v +++ b/powerpc/extractionMachdep.v @@ -23,3 +23,11 @@ Extract Constant Asm.symbol_is_rel_data => "C2C.atom_is_rel_data". Extract Constant Asm.ireg_eq => "fun (x: ireg) (y: ireg) -> x = y". Extract Constant Asm.freg_eq => "fun (x: freg) (y: freg) -> x = y". Extract Constant Asm.preg_eq => "fun (x: preg) (y: preg) -> x = y". + +(* Choice of PPC variant *) +Extract Constant Archi.ppc64 => + "begin match Configuration.model with + | ""ppc64"" -> true + | ""e5500"" -> true + | _ -> false + end". diff --git a/runtime/Makefile b/runtime/Makefile index 2fdaa4ec..99eeaa54 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -9,6 +9,16 @@ LIB=libcompcert.a INCLUDES=include/float.h include/stdarg.h include/stdbool.h \ include/stddef.h include/varargs.h +VPATH=$(ARCH) + +ifeq ($(ARCH),powerpc) +ifeq ($(MODEL),ppc64) +VPATH=powerpc/ppc64 $(ARCH) +else ifeq ($(MODEL),e5500) +VPATH=powerpc/ppc64 $(ARCH) +endif +endif + ifeq ($(strip $(HAS_RUNTIME_LIB)),true) all: $(LIB) else @@ -19,10 +29,10 @@ $(LIB): $(OBJS) rm -f $(LIB) ar rcs $(LIB) $(OBJS) -%.o: $(ARCH)/%.s +%.o: %.s $(CASMRUNTIME) -o $@ $^ -%.o: $(ARCH)/%.S +%.o: %.S $(CASMRUNTIME) -DMODEL_$(MODEL) -DABI_$(ABI) -DSYS_$(SYSTEM) -o $@ $^ clean:: diff --git a/runtime/powerpc/ppc64/i64_dtos.s b/runtime/powerpc/ppc64/i64_dtos.s new file mode 100644 index 00000000..95f7f700 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_dtos.s @@ -0,0 +1,52 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from double float to signed long + + .balign 16 + .globl __i64_dtos +__i64_dtos: + fctidz f1, f1 + stfdu f1, -16(r1) + lwz r3, 0(r1) + lwz r4, 4(r1) + addi r1, r1, 16 + blr + .type __i64_dtos, @function + .size __i64_dtos, .-__i64_dtos +
\ No newline at end of file diff --git a/runtime/powerpc/ppc64/i64_dtou.s b/runtime/powerpc/ppc64/i64_dtou.s new file mode 100644 index 00000000..60d5c9bf --- /dev/null +++ b/runtime/powerpc/ppc64/i64_dtou.s @@ -0,0 +1,66 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from double float to unsigned long + + .balign 16 + .globl __i64_dtou +__i64_dtou: + lis r0, 0x5f00 # 0x5f00_0000 = 2^63 in binary32 format + stwu r0, -16(r1) + lfs f2, 0(r1) # f2 = 2^63 + fcmpu cr0, f1, f2 # crbit 0 is f1 < f2 + bf 0, 1f # branch if f1 >= 2^63 (or f1 is NaN) + fctidz f1, f1 # convert as signed + stfd f1, 0(r1) + lwz r3, 0(r1) + lwz r4, 4(r1) + addi r1, r1, 16 + blr +1: fsub f1, f1, f2 # shift argument down by 2^63 + fctidz f1, f1 # convert as signed + stfd f1, 0(r1) + lwz r3, 0(r1) + lwz r4, 4(r1) + addis r3, r3, 0x8000 # shift result up by 2^63 + addi r1, r1, 16 + blr + .type __i64_dtou, @function + .size __i64_dtou, .-__i64_dtou + + diff --git a/runtime/powerpc/ppc64/i64_sar.s b/runtime/powerpc/ppc64/i64_sar.s new file mode 100644 index 00000000..4fc4451e --- /dev/null +++ b/runtime/powerpc/ppc64/i64_sar.s @@ -0,0 +1,51 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +# Shift right signed + + .balign 16 + .globl __i64_sar +__i64_sar: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + srad r4, r4, r5 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_sar, @function + .size __i64_sar, .-__i64_sar + +
\ No newline at end of file diff --git a/runtime/powerpc/ppc64/i64_sdiv.s b/runtime/powerpc/ppc64/i64_sdiv.s new file mode 100644 index 00000000..2bf5b574 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_sdiv.s @@ -0,0 +1,52 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Signed division + + .balign 16 + .globl __i64_sdiv +__i64_sdiv: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + rldimi r6, r5, 32, 0 # reassemble (r5,r6) as a 64-bit integer in r6 + divd r4, r4, r6 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_sdiv, @function + .size __i64_sdiv, .-__i64_sdiv + +
\ No newline at end of file diff --git a/runtime/powerpc/ppc64/i64_shl.s b/runtime/powerpc/ppc64/i64_shl.s new file mode 100644 index 00000000..955de565 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_shl.s @@ -0,0 +1,50 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +# Shift left + + .balign 16 + .globl __i64_shl +__i64_shl: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + sld r4, r4, r5 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_shl, @function + .size __i64_shl, .-__i64_shl +
\ No newline at end of file diff --git a/runtime/powerpc/ppc64/i64_shr.s b/runtime/powerpc/ppc64/i64_shr.s new file mode 100644 index 00000000..ca5ac9b2 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_shr.s @@ -0,0 +1,51 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +# Shift right unsigned + + .balign 16 + .globl __i64_shr +__i64_shr: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + srd r4, r4, r5 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_shr, @function + .size __i64_shr, .-__i64_shr + +
\ No newline at end of file diff --git a/runtime/powerpc/ppc64/i64_smod.s b/runtime/powerpc/ppc64/i64_smod.s new file mode 100644 index 00000000..35be366d --- /dev/null +++ b/runtime/powerpc/ppc64/i64_smod.s @@ -0,0 +1,54 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +## Signed remainder + + .balign 16 + .globl __i64_smod +__i64_smod: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + rldimi r6, r5, 32, 0 # reassemble (r5,r6) as a 64-bit integer in r6 + divd r0, r4, r6 + mulld r0, r0, r6 + subf r4, r0, r4 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_smod, @function + .size __i64_smod, .-__i64_smod + +
\ No newline at end of file diff --git a/runtime/powerpc/ppc64/i64_stod.s b/runtime/powerpc/ppc64/i64_stod.s new file mode 100644 index 00000000..3636d0b5 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_stod.s @@ -0,0 +1,50 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + +### Conversion from signed long to double float + + .balign 16 + .globl __i64_stod +__i64_stod: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + stdu r4, -16(r1) + lfd f1, 0(r1) + fcfid f1, f1 + addi r1, r1, 16 + blr + .type __i64_stod, @function + .size __i64_stod, .-__i64_stod + diff --git a/runtime/powerpc/ppc64/i64_stof.s b/runtime/powerpc/ppc64/i64_stof.s new file mode 100644 index 00000000..8830d594 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_stof.s @@ -0,0 +1,68 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from signed long to single float + + .balign 16 + .globl __i64_stof +__i64_stof: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + # Check whether -2^53 <= X < 2^53 + sradi r5, r4, 53 + addi r5, r5, 1 + cmpldi r5, 2 + blt 1f + # X is large enough that double rounding can occur. + # Avoid it by nudging X away from the points where double rounding + # occurs (the "round to odd" technique) + rldicl r5, r4, 0, 53 # extract bits 0 to 11 of X + addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF + # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-63 of r5 are 0 + or r4, r4, r5 # correct bit number 12 of X + rldicr r4, r4, 0, 52 # set to 0 bits 0 to 11 of X + # Convert to double, then round to single +1: stdu r4, -16(r1) + lfd f1, 0(r1) + fcfid f1, f1 + frsp f1, f1 + addi r1, r1, 16 + blr + .type __i64_stof, @function + .size __i64_stof, .-__i64_stof + diff --git a/runtime/powerpc/ppc64/i64_udiv.s b/runtime/powerpc/ppc64/i64_udiv.s new file mode 100644 index 00000000..a6a3bcb3 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_udiv.s @@ -0,0 +1,51 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Unsigned division + + .balign 16 + .globl __i64_udiv +__i64_udiv: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + rldimi r6, r5, 32, 0 # reassemble (r5,r6) as a 64-bit integer in r6 + divdu r4, r4, r6 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_udiv, @function + .size __i64_udiv, .-__i64_udiv + diff --git a/runtime/powerpc/ppc64/i64_umod.s b/runtime/powerpc/ppc64/i64_umod.s new file mode 100644 index 00000000..6bda1903 --- /dev/null +++ b/runtime/powerpc/ppc64/i64_umod.s @@ -0,0 +1,53 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Unsigned modulus + + .balign 16 + .globl __i64_umod +__i64_umod: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + rldimi r6, r5, 32, 0 # reassemble (r5,r6) as a 64-bit integer in r6 + divdu r0, r4, r6 + mulld r0, r0, r6 + subf r4, r0, r4 + srdi r3, r4, 32 # split r4 into (r3,r4) + blr + .type __i64_umod, @function + .size __i64_umod, .-__i64_umod + diff --git a/runtime/powerpc/ppc64/i64_utod.s b/runtime/powerpc/ppc64/i64_utod.s new file mode 100644 index 00000000..ddde91dd --- /dev/null +++ b/runtime/powerpc/ppc64/i64_utod.s @@ -0,0 +1,79 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the <organization> nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT +# HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from unsigned long to double float + + .balign 16 + .globl __i64_utod +__i64_utod: + rldicl r3, r3, 0, 32 # clear top 32 bits + rldicl r4, r4, 0, 32 # clear top 32 bits + lis r5, 0x4f80 # 0x4f80_0000 = 2^32 in binary32 format + stdu r3, -32(r1) + std r4, 8(r1) + stw r5, 16(r1) + lfd f1, 0(r1) # high 32 bits of argument + lfd f2, 8(r1) # low 32 bits of argument + lfs f3, 16(r1) # 2^32 + fcfid f1, f1 # convert both 32-bit halves to FP (exactly) + fcfid f2, f2 + fmadd f1, f1, f3, f2 # compute hi * 2^32 + lo + addi r1, r1, 32 + blr + .type __i64_utod, @function + .size __i64_utod, .-__i64_utod + +# Alternate implementation using round-to-odd: +# rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 +# cmpdi r4, 0 # is r4 >= 2^63 ? +# blt 1f +# stdu r4, -16(r1) # r4 < 2^63: convert as signed +# lfd f1, 0(r1) +# fcfid f1, f1 +# addi r1, r1, 16 +# blr +#1: rldicl r0, r4, 0, 63 # extract low bit of r4 +# srdi r4, r4, 1 +# or r4, r4, r0 # round r4 to 63 bits, using round-to-odd +# stdu r4, -16(r1) # convert to binary64 +# lfd f1, 0(r1) +# fcfid f1, f1 +# fadd f1, f1, f1 # multiply result by 2 +# addi r1, r1, 16 +# blr +
\ No newline at end of file diff --git a/test/regression/Results/builtins-powerpc b/test/regression/Results/builtins-powerpc index 0fd07f69..b131e543 100644 --- a/test/regression/Results/builtins-powerpc +++ b/test/regression/Results/builtins-powerpc @@ -15,6 +15,8 @@ fsel(-3.141590, 2.718000, 1.414000) = 1.414000 fcti(3.141590) = 3 fcti(2.718000) = 3 fcti(1.414000) = 1 +isel(0, 305419896, -559038737) = -559038737 +isel(42, 305419896, -559038737) = 305419896 read_16_rev = 3412 read_32_rev = efbeadde after write_16_rev: 9a78 diff --git a/test/regression/builtins-powerpc.c b/test/regression/builtins-powerpc.c index 90030737..5cb2e293 100644 --- a/test/regression/builtins-powerpc.c +++ b/test/regression/builtins-powerpc.c @@ -41,6 +41,8 @@ int main(int argc, char ** argv) __builtin_eieio(); __builtin_sync(); __builtin_isync(); + printf("isel(%d, %d, %d) = %d\n", 0, x, y, __builtin_isel(0, x, y)); + printf("isel(%d, %d, %d) = %d\n", 42, x, y, __builtin_isel(42, x, y)); printf ("read_16_rev = %x\n", __builtin_read16_reversed(&s)); printf ("read_32_rev = %x\n", __builtin_read32_reversed(&y)); __builtin_write16_reversed(&s, 0x789A); |