diff options
42 files changed, 603 insertions, 628 deletions
diff --git a/asmcomp/alpha/arch.ml b/asmcomp/alpha/arch.ml index 85c73c1a2..4ec4c78ed 100644 --- a/asmcomp/alpha/arch.ml +++ b/asmcomp/alpha/arch.ml @@ -14,7 +14,7 @@ (* Specific operations for the Alpha processor *) -open Formatmsg +open Format (* Addressing modes *) @@ -52,23 +52,23 @@ let num_args_addressing = function (* Printing operations and addressing modes *) -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Ibased(s, n) -> - printf "\"%s\"" s; - if n <> 0 then printf " + %i" n + | Ibased(s, n) -> + fprintf ppf "\"%s\"%s" s + (if n <> 0 then Printf.sprintf " + %i" n else "") | Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + fprintf ppf "%a%s" printreg arg.(0) + (if n <> 0 then Printf.sprintf " + %i" n else "") -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = match op with - Iadd4 -> printreg arg.(0); print_string " * 4 + "; printreg arg.(1) - | Iadd8 -> printreg arg.(0); print_string " * 8 + "; printreg arg.(1) - | Isub4 -> printreg arg.(0); print_string " * 4 - "; printreg arg.(1) - | Isub8 -> printreg arg.(0); print_string " * 8 - "; printreg arg.(1) - | Ireloadgp _ -> print_string "ldgp" - | Itrunc32 -> print_string "truncate32 "; printreg arg.(0) + | Iadd4 -> fprintf ppf "%a * 4 + %a" printreg arg.(0) printreg arg.(1) + | Iadd8 -> fprintf ppf "%a * 8 + %a" printreg arg.(0) printreg arg.(1) + | Isub4 -> fprintf ppf "%a * 4 - %a" printreg arg.(0) printreg arg.(1) + | Isub8 -> fprintf ppf "%a * 8 - %a" printreg arg.(0) printreg arg.(1) + | Ireloadgp _ -> fprintf ppf "ldgp" + | Itrunc32 -> fprintf ppf "truncate32 %a" printreg arg.(0) (* Distinguish between the Digital assembler and other assemblers (e.g. gas) *) diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index 1c9803792..9a4d15be1 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -15,7 +15,7 @@ (* Specific operations for the ARM processor *) open Misc -open Formatmsg +open Format (* Addressing modes *) @@ -57,29 +57,26 @@ let num_args_addressing (Iindexed n) = 1 (* Printing operations and addressing modes *) -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + | Iindexed n -> + printreg ppf arg.(0); + if n <> 0 then fprintf ppf " + %i" n -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = match op with - Ishiftarith(op, shift) -> - printreg arg.(0); - begin match op with - Ishiftadd -> print_string " + " - | Ishiftsub -> print_string " - " - | Ishiftsubrev -> print_string " -rev " - end; - printreg arg.(1); - if shift >= 0 - then printf " << %i" shift - else printf " >> %i" (-shift) + | Ishiftarith(op, shift) -> + let op_name = function + | Ishiftadd -> "+" + | Ishiftsub -> "-" + | Ishiftsubrev -> "-rev" in + let shift_mark = + if shift >= 0 + then sprintf "<< %i" shift + else sprintf ">> %i" (-shift) in + fprintf ppf "%a %s %a %s" + printreg arg.(0) (op_name op) printreg arg.(1) shift_mark | Ishiftcheckbound n -> - print_string "check "; - printreg arg.(0); - printf " >> %i > " n; - printreg arg.(1) + fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) | Irevsubimm n -> - print_int n; print_string " - "; printreg arg.(0) + fprintf ppf "%i %s %a" n "-" printreg arg.(0) diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 3fffff864..341d71c7b 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -14,7 +14,7 @@ (* From lambda to assembly code *) -open Formatmsg +open Format open Config open Clflags open Misc @@ -24,69 +24,66 @@ type error = Assembler_error of string exception Error of error -let liveness phrase = - Liveness.fundecl phrase; phrase +let liveness ppf phrase = + Liveness.fundecl ppf phrase; phrase -let dump_if flag message phrase = - if !flag then Printmach.phase message phrase +let dump_if ppf flag message phrase = + if !flag then Printmach.phase message ppf phrase -let pass_dump_if flag message phrase = - dump_if flag message phrase; phrase +let pass_dump_if ppf flag message phrase = + dump_if ppf flag message phrase; phrase -let pass_dump_linear_if flag message phrase = - if !flag then begin - printf "*** %s@." message; - Printlinear.fundecl phrase; print_newline() - end; +let pass_dump_linear_if ppf flag message phrase = + if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase -let rec regalloc round fd = +let rec regalloc ppf round fd = if round > 50 then fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); - dump_if dump_live "Liveness analysis" fd; + dump_if ppf dump_live "Liveness analysis" fd; Interf.build_graph fd; - if !dump_interf then Printmach.interferences(); - if !dump_prefer then Printmach.preferences(); + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); Coloring.allocate_registers(); - dump_if dump_regalloc "After register allocation" fd; + dump_if ppf dump_regalloc "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in - dump_if dump_reload "After insertion of reloading code" newfd; - if redo_regalloc - then begin Reg.reinit(); Liveness.fundecl newfd; regalloc (round+1) newfd end - else newfd + dump_if ppf dump_reload "After insertion of reloading code" newfd; + if redo_regalloc then begin + Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd + end else newfd let (++) x f = f x -let compile_fundecl fd_cmm = +let compile_fundecl (ppf : formatter) fd_cmm = Reg.reset(); fd_cmm ++ Selection.fundecl - ++ pass_dump_if dump_selection "After instruction selection" + ++ pass_dump_if ppf dump_selection "After instruction selection" ++ Comballoc.fundecl - ++ pass_dump_if dump_combine "After allocation combining" - ++ liveness - ++ pass_dump_if dump_live "Liveness analysis" + ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ liveness ppf + ++ pass_dump_if ppf dump_live "Liveness analysis" ++ Spill.fundecl - ++ liveness - ++ pass_dump_if dump_spill "After spilling" + ++ liveness ppf + ++ pass_dump_if ppf dump_spill "After spilling" ++ Split.fundecl - ++ pass_dump_if dump_split "After live range splitting" - ++ liveness - ++ regalloc 1 + ++ pass_dump_if ppf dump_split "After live range splitting" + ++ liveness ppf + ++ regalloc ppf 1 ++ Linearize.fundecl - ++ pass_dump_linear_if dump_linear "Linearized code" + ++ pass_dump_linear_if ppf dump_linear "Linearized code" ++ Scheduling.fundecl - ++ pass_dump_linear_if dump_scheduling "After instruction scheduling" + ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling" ++ Emit.fundecl -let compile_phrase p = - if !dump_cmm then begin Printcmm.phrase p; print_newline() end; +let compile_phrase ppf p = + if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p; match p with - Cfunction fd -> compile_fundecl fd + | Cfunction fd -> compile_fundecl ppf fd | Cdata dl -> Emit.data dl -let compile_implementation prefixname (size, lam) = +let compile_implementation prefixname ppf (size, lam) = let asmfile = if !keep_asm_file then prefixname ^ ext_asm @@ -97,7 +94,7 @@ let compile_implementation prefixname (size, lam) = Emit.begin_assembly(); Closure.intro size lam ++ Cmmgen.compunit size - ++ List.iter compile_phrase ++ (fun () -> ()); + ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); Emit.end_assembly(); close_out oc with x -> @@ -111,6 +108,6 @@ let compile_implementation prefixname (size, lam) = (* Error report *) -let report_error = function - Assembler_error file -> - printf "Assembler error, input left in file %s" file +let report_error ppf = function + | Assembler_error file -> + fprintf ppf "Assembler error, input left in file %s" file diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 3dedf0be6..0f6b831ce 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -14,9 +14,11 @@ (* From lambda to assembly code *) -val compile_implementation: string -> int * Lambda.lambda -> unit -val compile_phrase: Cmm.phrase -> unit +val compile_implementation : + string -> Format.formatter -> int * Lambda.lambda -> unit +val compile_phrase : + Format.formatter -> Cmm.phrase -> unit type error = Assembler_error of string exception Error of error -val report_error: error -> unit +val report_error: Format.formatter -> error -> unit diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index eb8760507..e4ee6b1ba 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -60,11 +60,11 @@ let create_archive file_list lib_name = remove_file archive_name; raise x -open Formatmsg +open Format -let report_error = function - File_not_found name -> - printf "Cannot find file %s" name +let report_error ppf = function + | File_not_found name -> + fprintf ppf "Cannot find file %s" name | Archiver_error name -> - printf "Error while creating the library %s" name + fprintf ppf "Error while creating the library %s" name diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli index a561c3428..66f6a127f 100644 --- a/asmcomp/asmlibrarian.mli +++ b/asmcomp/asmlibrarian.mli @@ -14,6 +14,8 @@ (* Build libraries of .cmx files *) +open Format + val create_archive: string list -> string -> unit type error = @@ -22,4 +24,4 @@ type error = exception Error of error -val report_error: error -> unit +val report_error: formatter -> error -> unit diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 9924a898a..839c2448a 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -153,14 +153,15 @@ module IntSet = Set.Make( let compare = compare end) -let make_startup_file filename info_list = +let make_startup_file ppf filename info_list = + let compile_phrase p = Asmgen.compile_phrase ppf p in let oc = open_out filename in Emitaux.output_channel := oc; Location.input_name := "startup"; (* set the name of the "current" input *) Compilenv.reset "startup"; (* set the name of the "current" compunit *) Emit.begin_assembly(); let name_list = List.map (fun ui -> ui.ui_name) info_list in - Asmgen.compile_phrase(Cmmgen.entry_point name_list); + compile_phrase (Cmmgen.entry_point name_list); let apply_functions = ref (IntSet.add 2 (IntSet.add 3 IntSet.empty)) in (* The callback functions always reference caml_apply[23] *) let curry_functions = @@ -175,24 +176,24 @@ let make_startup_file filename info_list = info.ui_curry_fun) info_list; IntSet.iter - (fun n -> Asmgen.compile_phrase(Cmmgen.apply_function n)) + (fun n -> compile_phrase (Cmmgen.apply_function n)) !apply_functions; IntSet.iter - (fun n -> List.iter Asmgen.compile_phrase (Cmmgen.curry_function n)) + (fun n -> List.iter (compile_phrase) (Cmmgen.curry_function n)) !curry_functions; Array.iter - (fun name -> Asmgen.compile_phrase(Cmmgen.predef_exception name)) + (fun name -> compile_phrase (Cmmgen.predef_exception name)) Runtimedef.builtin_exceptions; - Asmgen.compile_phrase(Cmmgen.global_table name_list); - Asmgen.compile_phrase + compile_phrase (Cmmgen.global_table name_list); + compile_phrase (Cmmgen.globals_map (List.map (fun name -> let (auth_name,crc) = Hashtbl.find crc_interfaces name in (name,crc)) name_list)); - Asmgen.compile_phrase(Cmmgen.data_segment_table ("startup" :: name_list)); - Asmgen.compile_phrase(Cmmgen.code_segment_table ("startup" :: name_list)); - Asmgen.compile_phrase + compile_phrase(Cmmgen.data_segment_table ("startup" :: name_list)); + compile_phrase(Cmmgen.code_segment_table ("startup" :: name_list)); + compile_phrase (Cmmgen.frame_table("startup" :: "system" :: name_list)); Emit.end_assembly(); close_out oc @@ -269,7 +270,7 @@ let object_file_name name = (* Main entry point *) -let link objfiles = +let link ppf objfiles = let objfiles = if !Clflags.nopervasives then objfiles @@ -286,7 +287,7 @@ let link objfiles = Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.ccopts := !Clflags.ccopts @ !lib_ccopts; let startup = Filename.temp_file "camlstartup" ext_asm in - make_startup_file startup units_tolink; + make_startup_file ppf startup units_tolink; let startup_obj = Filename.temp_file "camlstartup" ext_obj in if Proc.assemble_file startup startup_obj <> 0 then raise(Error(Assembler_error startup)); @@ -300,38 +301,38 @@ let link objfiles = (* Error report *) -open Formatmsg +open Format -let report_error = function - File_not_found name -> - printf "Cannot find file %s" name +let report_error ppf = function + | File_not_found name -> + fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> - printf "The file %s is not a compilation unit description" name + fprintf ppf "The file %s is not a compilation unit description" name | Missing_implementations l -> - printf - "@[<v 2>No implementations provided for the following modules:%t@]" - (fun fmt -> - List.iter - (fun (md, rq) -> - printf "@ @[<hov 2>%s referenced from %t@]" - md - (fun fmt -> - match rq with - [] -> () - | r1::rl -> printf "%s" r1; - List.iter (fun r -> printf ",@ %s" r) rl)) - l) + let print_references ppf = function + | [] -> () + | r1 :: rl -> + fprintf ppf "%s" r1; + List.iter (fun r -> fprintf ppf ",@ %s" r) rl in + let print_modules ppf = + List.iter + (fun (md, rq) -> + fprintf ppf "@ @[<hov 2>%s referenced from %a@]" md + print_references rq) in + fprintf ppf + "@[<v 2>No implementations provided for the following modules:%a@]" + print_modules l | Inconsistent_interface(intf, file1, file2) -> - printf + fprintf ppf "@[<hv>Files %s@ and %s@ make inconsistent assumptions \ over interface %s@]" file1 file2 intf | Inconsistent_implementation(intf, file1, file2) -> - printf + fprintf ppf "@[<hv>Files %s@ and %s@ make inconsistent assumptions \ over implementation %s@]" file1 file2 intf | Assembler_error file -> - printf "Error while assembling %s" file + fprintf ppf "Error while assembling %s" file | Linking_error -> - print_string "Error during linking" + fprintf ppf "Error during linking" diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index dc7fc9058..96747b763 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -14,7 +14,9 @@ (* Link a set of .cmx/.o files and produce an executable *) -val link: string list -> unit +open Format + +val link: formatter -> string list -> unit type error = File_not_found of string @@ -27,4 +29,4 @@ type error = exception Error of error -val report_error: error -> unit +val report_error: formatter -> error -> unit diff --git a/asmcomp/codegen.ml b/asmcomp/codegen.ml index a292117ae..fe841e70e 100644 --- a/asmcomp/codegen.ml +++ b/asmcomp/codegen.ml @@ -14,7 +14,7 @@ (* From C-- to assembly code *) -open Formatmsg +open Format open Cmm let dump_cmm = ref false @@ -43,10 +43,10 @@ let rec regalloc fd = then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end else newfd -let fundecl fd_cmm = +let fundecl ppf fd_cmm = if !dump_cmm then begin - printf "*** C-- code@."; - Printcmm.fundecl fd_cmm; print_newline() + fprintf ppf "*** C-- code@."; + fprintf ppf "%a@." Printcmm.fundecl fd_cmm end; Reg.reset(); let fd_sel = Sequence.fundecl fd_cmm in diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index beb7777c6..9677d5a5a 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -112,7 +112,7 @@ let global_approx global_ident = find_in_path !load_path (String.uncapitalize modname ^ ".cmx") in let (ui, crc) = read_unit_info filename in if ui.ui_name <> modname then - raise(Error(Illegal_renaming(modname, filename))); + raise(Error(Illegal_renaming(ui.ui_name, filename))); (ui.ui_approx, crc) with Not_found -> (Value_unknown, cmx_not_found_crc) in @@ -151,13 +151,13 @@ let save_unit_info filename = (* Error report *) -open Formatmsg +open Format -let report_error = function - Not_a_unit_info filename -> - printf "%s@ is not a compilation unit description." filename +let report_error ppf = function + | Not_a_unit_info filename -> + fprintf ppf "%s@ is not a compilation unit description." filename | Corrupted_unit_info filename -> - printf "Corrupted compilation unit description@ %s" filename + fprintf ppf "Corrupted compilation unit description@ %s" filename | Illegal_renaming(modname, filename) -> - printf "%s@ contains the description for unit@ %s" filename modname + fprintf ppf "%s@ contains the description for unit@ %s" filename modname diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 5c0ca1ceb..db645d66a 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -76,4 +76,4 @@ type error = exception Error of error -val report_error: error -> unit +val report_error: Format.formatter -> error -> unit diff --git a/asmcomp/hppa/arch.ml b/asmcomp/hppa/arch.ml index efb49a7e6..b1af845bc 100644 --- a/asmcomp/hppa/arch.ml +++ b/asmcomp/hppa/arch.ml @@ -14,7 +14,7 @@ (* Specific operations for the HP PA-RISC processor *) -open Formatmsg +open Format type specific_operation = Ishift1add @@ -50,18 +50,18 @@ let num_args_addressing = function (* Printing operations and addressing modes *) -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Ibased(s, n) -> - printf "\"%s\"" s; - if n <> 0 then printf " + %i" n + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx | Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = match op with - Ishift1add -> printreg arg.(0); print_string " << 1 + "; printreg arg.(1) - | Ishift2add -> printreg arg.(0); print_string " << 2 + "; printreg arg.(1) - | Ishift3add -> printreg arg.(0); print_string " << 3 + "; printreg arg.(1) + | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1) + | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1) + | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1) diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index a55324e39..de9d6df6b 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -14,6 +14,8 @@ (* Specific operations for the Intel 386 processor *) +open Format + type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) @@ -67,71 +69,61 @@ let num_args_addressing = function (* Printing operations and addressing modes *) -open Formatmsg - -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Ibased(s, 0) -> - printf "\"%s\"" s + | Ibased(s, 0) -> + fprintf ppf "\"%s\"" s | Ibased(s, n) -> - printf "\"%s\" + %i" s n + fprintf ppf "\"%s\" + %i" s n | Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx | Iindexed2 n -> - printreg arg.(0); print_string " + "; printreg arg.(1); - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx | Iscaled(scale, n) -> - printreg arg.(0); printf " * %i" scale; - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a * %i%s" printreg arg.(0) scale idx | Iindexed2scaled(scale, n) -> - printreg arg.(0); print_string " + "; printreg arg.(1); - printf " * %i" scale; - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = match op with - Ilea addr -> print_addressing printreg addr arg + | Ilea addr -> print_addressing printreg addr ppf arg | Istore_int(n, addr) -> - print_string "["; print_addressing printreg addr arg; - print_string "] := "; print_string (Nativeint.to_string n) + fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg + (Nativeint.to_string n) | Istore_symbol(lbl, addr) -> - print_string "["; print_addressing printreg addr arg; - print_string "] := \""; print_string lbl; print_string "\"" + fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl | Ioffset_loc(n, addr) -> - print_string "["; print_addressing printreg addr arg; - print_string "] +:= "; print_int n + fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> - print_string "push "; + fprintf ppf "push "; for i = 0 to Array.length arg - 1 do - if i > 0 then print_string ", "; - printreg arg.(i) + if i > 0 then fprintf ppf ", "; + printreg ppf arg.(i) done | Ipush_int n -> - printf "push %s" (Nativeint.to_string n) + fprintf ppf "push %s" (Nativeint.to_string n) | Ipush_symbol s -> - printf "push \"%s\"" s + fprintf ppf "push \"%s\"" s | Ipush_load addr -> - print_string "push ["; print_addressing printreg addr arg; - print_string "]" + fprintf ppf "push [%a]" (print_addressing printreg addr) arg | Ipush_load_float addr -> - print_string "pushfloat ["; print_addressing printreg addr arg; - print_string "]" + fprintf ppf "pushfloat [%a]" (print_addressing printreg addr) arg | Isubfrev -> - printreg arg.(0); print_string " -f(rev) "; printreg arg.(1) + fprintf ppf "%a -f(rev) %a" printreg arg.(0) printreg arg.(1) | Idivfrev -> - printreg arg.(0); print_string " /f(rev) "; printreg arg.(1) + fprintf ppf "%a /f(rev) %a" printreg arg.(0) printreg arg.(1) | Ifloatarithmem(double, op, addr) -> - printreg arg.(0); - begin match op with - Ifloatadd -> print_string " +f " - | Ifloatsub -> print_string " -f " - | Ifloatsubrev -> print_string " -f(rev) " - | Ifloatmul -> print_string " *f " - | Ifloatdiv -> print_string " /f " - | Ifloatdivrev -> print_string " /f(rev) " - end; - print_string (if double then "float64" else "float32"); - print_string "["; - print_addressing printreg addr (Array.sub arg 1 (Array.length arg - 1)); - print_string "]" + let op_name = function + | Ifloatadd -> "+f" + | Ifloatsub -> "-f" + | Ifloatsubrev -> "-f(rev)" + | Ifloatmul -> "*f" + | Ifloatdiv -> "/f" + | Ifloatdivrev -> "/f(rev)" in + let long = if double then "float64" else "float32" in + fprintf ppf "%a %s %s[%a]" printreg arg.(0) (op_name op) long + (print_addressing printreg addr) (Array.sub arg 1 (Array.length arg - 1)) diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 775eba6dd..fcbb20839 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -102,11 +102,11 @@ let rec live i finally = i.live <- across; Reg.add_set_array across i.arg -let fundecl f = +let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in (* Sanity check: only function parameters can be live at entrypoint *) let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in if not (Reg.Set.is_empty wrong_live) then begin - Printmach.regset wrong_live; Formatmsg.print_newline(); + Format.fprintf ppf "%a@." Printmach.regset wrong_live; Misc.fatal_error "Liveness.fundecl" end diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli index 8339c7d35..3353b4443 100644 --- a/asmcomp/liveness.mli +++ b/asmcomp/liveness.mli @@ -15,4 +15,6 @@ (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) -val fundecl: Mach.fundecl -> unit +open Format + +val fundecl: formatter -> Mach.fundecl -> unit diff --git a/asmcomp/mips/arch.ml b/asmcomp/mips/arch.ml index ed361c2ae..50f067de8 100644 --- a/asmcomp/mips/arch.ml +++ b/asmcomp/mips/arch.ml @@ -15,7 +15,7 @@ (* Specific operations for the Mips processor *) open Misc -open Formatmsg +open Format (* Addressing modes *) @@ -54,14 +54,14 @@ let num_args_addressing = function (* Printing operations and addressing modes *) -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Ibased(s, n) -> - printf "\"%s\"" s; - if n <> 0 then printf " + %i" n + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx | Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = fatal_error "Arch_mips.print_specific_operation" diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 802cbc8be..068445f5b 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -14,7 +14,7 @@ (* Specific operations for the PowerPC processor *) -open Formatmsg +open Format type specific_operation = Imultaddf (* multiply and add *) @@ -52,31 +52,31 @@ let num_args_addressing = function (* Printing operations and addressing modes *) -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Ibased(s, n) -> - printf "\"%s\"" s; - if n <> 0 then printf " + %i" n + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx | Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx | Iindexed2 -> - printreg arg.(0); print_string " + "; printreg arg.(1) + fprintf ppf "%a + %a" printreg arg.(0) printreg arg.(1) -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = match op with - Imultaddf -> - printreg arg.(0); print_string " *f "; printreg arg.(1); - print_string " +f "; printreg arg.(2) + | Imultaddf -> + fprintf ppf "%a *f %a +f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) | Imultsubf -> - printreg arg.(0); print_string " *f "; printreg arg.(1); - print_string " -f "; printreg arg.(2) + fprintf ppf "%a *f %a -f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) (* Distinguish between the PowerPC and the Power/RS6000 submodels *) let powerpc = match Config.model with - "ppc" -> true + | "ppc" -> true | "rs6000" -> false | _ -> Misc.fatal_error "wrong $(MODEL)" @@ -86,7 +86,7 @@ let powerpc = let toc = match Config.system with - "aix" -> true + | "aix" -> true | "elf" -> false | "rhapsody" -> false | _ -> Misc.fatal_error "wrong $(SYSTEM)" diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 149fb86b6..3e51b0401 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -14,184 +14,180 @@ (* Pretty-printing of C-- code *) -open Formatmsg +open Format open Cmm -let machtype_component = function - Addr -> print_string "addr" - | Int -> print_string "int" - | Float -> print_string "float" +let machtype_component ppf = function + | Addr -> fprintf ppf "addr" + | Int -> fprintf ppf "int" + | Float -> fprintf ppf "float" -let machtype mty = +let machtype ppf mty = match Array.length mty with - 0 -> print_string "unit" - | n -> machtype_component mty.(0); + | 0 -> fprintf ppf "unit" + | n -> machtype_component ppf mty.(0); for i = 1 to n-1 do - print_string "*"; machtype_component mty.(i) + fprintf ppf "*%a" machtype_component mty.(i) done let comparison = function - Ceq -> print_string "==" - | Cne -> print_string "!=" - | Clt -> print_string "<" - | Cle -> print_string "<=" - | Cgt -> print_string ">" - | Cge -> print_string ">=" + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" let chunk = function - Byte_unsigned -> print_string "unsigned int8" - | Byte_signed -> print_string "signed int8" - | Sixteen_unsigned -> print_string "unsigned int16" - | Sixteen_signed -> print_string "signed int16" - | Thirtytwo_unsigned -> print_string "unsigned int32" - | Thirtytwo_signed -> print_string "signed int32" - | Word -> () - | Single -> print_string "float32" - | Double -> print_string "float64" - | Double_u -> print_string "float64u" + | Byte_unsigned -> "unsigned int8" + | Byte_signed -> "signed int8" + | Sixteen_unsigned -> "unsigned int16" + | Sixteen_signed -> "signed int16" + | Thirtytwo_unsigned -> "unsigned int32" + | Thirtytwo_signed -> "signed int32" + | Word -> "" + | Single -> "float32" + | Double -> "float64" + | Double_u -> "float64u" let operation = function - Capply ty -> print_string "app" - | Cextcall(lbl, ty, alloc) -> printf "extcall \"%s\"" lbl - | Cload Word -> print_string "load" - | Cload c -> print_string "load "; chunk c - | Calloc -> print_string "alloc" - | Cstore Word -> print_string "store" - | Cstore c -> print_string "store "; chunk c - | Caddi -> print_string "+" - | Csubi -> print_string "-" - | Cmuli -> print_string "*" - | Cdivi -> print_string "/" - | Cmodi -> print_string "mod" - | Cand -> print_string "and" - | Cor -> print_string "or" - | Cxor -> print_string "xor" - | Clsl -> print_string "<<" - | Clsr -> print_string ">>u" - | Casr -> print_string ">>s" + | Capply ty -> "app" + | Cextcall(lbl, ty, alloc) -> Printf.sprintf "extcall \"%s\"" lbl + | Cload Word -> "load" + | Cload c -> Printf.sprintf "load %s" (chunk c) + | Calloc -> "alloc" + | Cstore Word -> "store" + | Cstore c -> Printf.sprintf "store %s" (chunk c) + | Caddi -> "+" + | Csubi -> "-" + | Cmuli -> "*" + | Cdivi -> "/" + | Cmodi -> "mod" + | Cand -> "and" + | Cor -> "or" + | Cxor -> "xor" + | Clsl -> "<<" + | Clsr -> ">>u" + | Casr -> ">>s" | Ccmpi c -> comparison c - | Cadda -> print_string "+a" - | Csuba -> print_string "-a" - | Ccmpa c -> comparison c; print_string "a" - | Cnegf -> print_string "~f" - | Cabsf -> print_string "absf" - | Caddf -> print_string "+f" - | Csubf -> print_string "-f" - | Cmulf -> print_string "*f" - | Cdivf -> print_string "/f" - | Cfloatofint -> print_string "floatofint" - | Cintoffloat -> print_string "intoffloat" - | Ccmpf c -> comparison c; print_string "f" - | Craise -> print_string "raise" - | Ccheckbound -> print_string "checkbound" - -let print_id ppf id = Ident.print ppf id;; + | Cadda -> "+a" + | Csuba -> "-a" + | Ccmpa c -> Printf.sprintf "%sa" (comparison c) + | Cnegf -> "~f" + | Cabsf -> "absf" + | Caddf -> "+f" + | Csubf -> "-f" + | Cmulf -> "*f" + | Cdivf -> "/f" + | Cfloatofint -> "floatofint" + | Cintoffloat -> "intoffloat" + | Ccmpf c -> Printf.sprintf "%sf" (comparison c) + | Craise -> "raise" + | Ccheckbound -> "checkbound" let rec expr ppf = function - Cconst_int n -> print_int n - | Cconst_natint n -> print_string(Nativeint.to_string n) - | Cconst_float s -> print_string s - | Cconst_symbol s -> printf "\"%s\"" s - | Cconst_pointer n -> printf "%ia" n - | Cconst_natpointer n -> printf "%sa" (Nativeint.to_string n) + | Cconst_int n -> fprintf ppf "%i" n + | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) + | Cconst_float s -> fprintf ppf "%s" s + | Cconst_symbol s -> fprintf ppf "\"%s\"" s + | Cconst_pointer n -> fprintf ppf "%ia" n + | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) | Cvar id -> Ident.print ppf id | Clet(id, def, (Clet(_, _, _) as body)) -> let print_binding id ppf def = - printf "@[<2>%a@ %a@]" print_id id expr def in + fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in let rec in_part ppf = function | Clet(id, def, body) -> - printf "@ %a" (print_binding id) def; + fprintf ppf "@ %a" (print_binding id) def; in_part ppf body | exp -> exp in - printf "@[<2>(let@ @[<1>(%a" (print_binding id) def; + fprintf ppf "@[<2>(let@ @[<1>(%a" (print_binding id) def; let exp = in_part ppf body in - printf ")@]@ %a)@]" sequence exp + fprintf ppf ")@]@ %a)@]" sequence exp | Clet(id, def, body) -> - printf "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]" print_id id expr def sequence body + fprintf ppf + "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]" + Ident.print id expr def sequence body | Cassign(id, exp) -> - printf "@[<2>(assign @[<2>%a@ %a@])@]" print_id id expr exp + fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp | Ctuple el -> let tuple ppf el = let first = ref true in List.iter (fun e -> - if !first then first := false else print_space(); + if !first then first := false else fprintf ppf "@ "; expr ppf e) el in - printf "@[<1>[%a]@]" tuple el + fprintf ppf "@[<1>[%a]@]" tuple el | Cop(op, el) -> - printf "@[<2>("; - operation op; - List.iter (fun e -> printf "@ %a" expr e) el; + fprintf ppf "@[<2>(%s" (operation op); + List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with - Capply mty -> print_space(); machtype mty - | Cextcall(_, mty, _) -> print_space(); machtype mty + | Capply mty -> fprintf ppf "@ %a" machtype mty + | Cextcall(_, mty, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; - printf ")@]" + fprintf ppf ")@]" | Csequence(e1, e2) -> - printf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2 + fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2 | Cifthenelse(e1, e2, e3) -> - printf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3 + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3 | Cswitch(e1, index, cases) -> let print_case i ppf = for j = 0 to Array.length index - 1 do - if index.(j) = i then printf "case %i:" j + if index.(j) = i then fprintf ppf "case %i:" j done in let print_cases ppf = for i = 0 to Array.length cases - 1 do - printf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i) + fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i) done in - printf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases + fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases | Cloop e -> - printf "@[<2>(loop@ %a)@]" sequence e + fprintf ppf "@[<2>(loop@ %a)@]" sequence e | Ccatch(e1, e2) -> - printf "@[<2>(catch@ %a@;<1 -2>with@ %a)@]" sequence e1 sequence e2 + fprintf ppf "@[<2>(catch@ %a@;<1 -2>with@ %a)@]" sequence e1 sequence e2 | Cexit -> - print_string "exit" + fprintf ppf "exit" | Ctrywith(e1, id, e2) -> - printf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" - sequence e1 print_id id sequence e2 + fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" + sequence e1 Ident.print id sequence e2 and sequence ppf = function - Csequence(e1, e2) -> - printf "%a@ %a" sequence e1 sequence e2 - | e -> - expression e + | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2 + | e -> expression ppf e -and expression e = printf "%a" expr e +and expression ppf e = fprintf ppf "%a" expr e -let fundecl f = +let fundecl ppf f = let print_cases ppf cases = let first = ref true in List.iter (fun (id, ty) -> - if !first then first := false else print_space(); - printf "%a: " print_id id; - machtype ty) + if !first then first := false else fprintf ppf "@ "; + fprintf ppf "%a: %a" Ident.print id machtype ty) cases in - printf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." + fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." f.fun_name print_cases f.fun_args sequence f.fun_body -let data_item = function - Cdefine_symbol s -> printf "\"%s\":" s - | Cdefine_label l -> printf "L%i:" l - | Cint8 n -> printf "byte %i" n - | Cint16 n -> printf "int16 %i" n - | Cint32 n -> printf "int32 %s" (Nativeint.to_string n) - | Cint n -> printf "int %s" (Nativeint.to_string n) - | Csingle f -> printf "single %s" f - | Cdouble f -> printf "double %s" f - | Csymbol_address s -> printf "addr \"%s\"" s - | Clabel_address l -> printf "addr L%i" l - | Cstring s -> printf "string \"%s\"" s - | Cskip n -> printf "skip %i" n - | Calign n -> printf "align %i" n - -let data dl = - let items ppf = List.iter (fun d -> print_space(); data_item d) dl in - printf "@[<hv 1>(data%t)@]" items - -let phrase = function - Cfunction f -> fundecl f - | Cdata dl -> data dl +let data_item ppf = function + | Cdefine_symbol s -> fprintf ppf "\"%s\":" s + | Cdefine_label l -> fprintf ppf "L%i:" l + | Cint8 n -> fprintf ppf "byte %i" n + | Cint16 n -> fprintf ppf "int16 %i" n + | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) + | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) + | Csingle f -> fprintf ppf "single %s" f + | Cdouble f -> fprintf ppf "double %s" f + | Csymbol_address s -> fprintf ppf "addr \"%s\"" s + | Clabel_address l -> fprintf ppf "addr L%i" l + | Cstring s -> fprintf ppf "string \"%s\"" s + | Cskip n -> fprintf ppf "skip %i" n + | Calign n -> fprintf ppf "align %i" n + +let data ppf dl = + let items ppf = List.iter (fun d -> fprintf ppf "@ %a" data_item d) dl in + fprintf ppf "@[<hv 1>(data%t)@]" items + +let phrase ppf = function + | Cfunction f -> fundecl ppf f + | Cdata dl -> data ppf dl diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli index 95840dce9..d498ddb72 100644 --- a/asmcomp/printcmm.mli +++ b/asmcomp/printcmm.mli @@ -14,12 +14,14 @@ (* Pretty-printing of C-- code *) -val machtype_component : Cmm.machtype_component -> unit -val machtype : Cmm.machtype_component array -> unit -val comparison : Cmm.comparison -> unit -val chunk : Cmm.memory_chunk -> unit -val operation : Cmm.operation -> unit -val expression : Cmm.expression -> unit -val fundecl : Cmm.fundecl -> unit -val data : Cmm.data_item list -> unit -val phrase : Cmm.phrase -> unit +open Format + +val machtype_component : formatter -> Cmm.machtype_component -> unit +val machtype : formatter -> Cmm.machtype_component array -> unit +val comparison : Cmm.comparison -> string +val chunk : Cmm.memory_chunk -> string +val operation : Cmm.operation -> string +val expression : formatter -> Cmm.expression -> unit +val fundecl : formatter -> Cmm.fundecl -> unit +val data : formatter -> Cmm.data_item list -> unit +val phrase : formatter -> Cmm.phrase -> unit diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 4ec37e47f..cf2baa078 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -14,7 +14,7 @@ (* Pretty-printing of linearized machine code *) -open Formatmsg +open Format open Mach open Printmach open Linearize @@ -22,55 +22,53 @@ open Linearize let label ppf l = Format.fprintf ppf "L%i" l -let instr i = +let instr ppf i = match i.desc with - Lend -> () + | Lend -> () | Lop op -> begin match op with - Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> - printf "@[<1>{"; - regsetaddr i.live; - printf "}@]@," + | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> + fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live | _ -> () end; - operation op i.arg i.res + operation op i.arg ppf i.res | Lreloadretaddr -> - print_string "reload retaddr" + fprintf ppf "reload retaddr" | Lreturn -> - print_string "return "; regs i.arg + fprintf ppf "return %a" regs i.arg | Llabel lbl -> - printf "%a:" label lbl + fprintf ppf "%a:" label lbl | Lbranch lbl -> - printf "goto %a" label lbl + fprintf ppf "goto %a" label lbl | Lcondbranch(tst, lbl) -> - printf "if "; test tst i.arg; printf " goto %a" label lbl + fprintf ppf "if %a goto %a" (test tst) i.arg label lbl | Lcondbranch3(lbl0, lbl1, lbl2) -> - print_string "switch3 "; reg i.arg.(0); + fprintf ppf "switch3 %a" reg i.arg.(0); let case n = function - None -> () + | None -> () | Some lbl -> - printf "@,case %i: goto %a" n label lbl in + fprintf ppf "@,case %i: goto %a" n label lbl in case 0 lbl0; case 1 lbl1; case 2 lbl2; - printf "@,endswitch" + fprintf ppf "@,endswitch" | Lswitch lblv -> - printf "switch "; reg i.arg.(0); + fprintf ppf "switch %a" reg i.arg.(0); for i = 0 to Array.length lblv - 1 do - printf "case %i: goto %a" i label lblv.(i) + fprintf ppf "case %i: goto %a" i label lblv.(i) done; - printf "@,endswitch" + fprintf ppf "@,endswitch" | Lsetuptrap lbl -> - printf "setup trap %a" label lbl + fprintf ppf "setup trap %a" label lbl | Lpushtrap -> - print_string "push trap" + fprintf ppf "push trap" | Lpoptrap -> - print_string "pop trap" + fprintf ppf "pop trap" | Lraise -> - print_string "raise "; reg i.arg.(0) + fprintf ppf "raise %a" reg i.arg.(0) let rec all_instr ppf i = match i.desc with - Lend -> () - | _ -> instr i; printf "@,%a" all_instr i.next + | Lend -> () + | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next -let fundecl f = - printf "@[<v 2>%s:@,%a@]" f.fun_name all_instr f.fun_body +let fundecl ppf f = + fprintf ppf "@[<v 2>%s:@,%a@]" f.fun_name all_instr f.fun_body diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli index 952a4dd97..5e90c11c6 100644 --- a/asmcomp/printlinear.mli +++ b/asmcomp/printlinear.mli @@ -14,7 +14,8 @@ (* Pretty-printing of linearized machine code *) +open Format open Linearize -val instr: instruction -> unit -val fundecl: fundecl -> unit +val instr: formatter -> instruction -> unit +val fundecl: formatter -> fundecl -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 039ac7537..88165c436 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -14,219 +14,203 @@ (* Pretty-printing of pseudo machine code *) -open Formatmsg +open Format open Cmm open Reg open Mach -let register ppf r = +let reg ppf r = if String.length r.name > 0 then - print_string r.name + fprintf ppf "%s" r.name else - print_string(match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); - printf "/%i" r.stamp; + fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); + fprintf ppf "/%i" r.stamp; begin match r.loc with - Unknown -> () + | Unknown -> () | Reg r -> - printf "[%s]" (Proc.register_name r) + fprintf ppf "[%s]" (Proc.register_name r) | Stack(Local s) -> - printf "[s%i]" s + fprintf ppf "[s%i]" s | Stack(Incoming s) -> - printf "[si%i]" s + fprintf ppf "[si%i]" s | Stack(Outgoing s) -> - printf "[so%i]" s + fprintf ppf "[so%i]" s end -let reg r = printf "%a" register r - -let regs v = +let regs ppf v = match Array.length v with - 0 -> () - | 1 -> reg v.(0) - | n -> reg v.(0); - for i = 1 to n-1 do print_string " "; reg v.(i) done + | 0 -> () + | 1 -> reg ppf v.(0) + | n -> reg ppf v.(0); + for i = 1 to n-1 do fprintf ppf "@ %a" reg v.(i) done -let regset s = +let regset ppf s = let first = ref true in Reg.Set.iter (fun r -> - if !first then first := false else print_space(); - reg r) + if !first then begin first := false; fprintf ppf "%a" reg r end + else fprintf ppf "@ %a" reg r) s -let regsetaddr s = +let regsetaddr ppf s = let first = ref true in Reg.Set.iter (fun r -> - if !first then first := false else print_space(); - reg r; - match r.typ with Addr -> print_string "*" | _ -> ()) + if !first then begin first := false; fprintf ppf "%a" reg r end + else fprintf ppf "@ %a" reg r; + match r.typ with Addr -> fprintf ppf "*" | _ -> ()) s let intcomp = function - Isigned c -> print_string " "; Printcmm.comparison c; print_string "s " - | Iunsigned c -> print_string " "; Printcmm.comparison c; print_string "u " + | Isigned c -> Printf.sprintf " %ss " (Printcmm.comparison c) + | Iunsigned c -> Printf.sprintf " %su " (Printcmm.comparison c) let floatcomp c = - print_string " "; Printcmm.comparison c; print_string "f " + Printf.sprintf " %sf " (Printcmm.comparison c) let intop = function - Iadd -> print_string " + " - | Isub -> print_string " - " - | Imul -> print_string " * " - | Idiv -> print_string " div " - | Imod -> print_string " mod " - | Iand -> print_string " & " - | Ior -> print_string " | " - | Ixor -> print_string " ^ " - | Ilsl -> print_string " << " - | Ilsr -> print_string " >>u " - | Iasr -> print_string " >>s " + | Iadd -> " + " + | Isub -> " - " + | Imul -> " * " + | Idiv -> " div " + | Imod -> " mod " + | Iand -> " & " + | Ior -> " | " + | Ixor -> " ^ " + | Ilsl -> " << " + | Ilsr -> " >>u " + | Iasr -> " >>s " | Icomp cmp -> intcomp cmp - | Icheckbound -> print_string " check > " - -let test tst arg = + | Icheckbound -> " check > " + +let test tst ppf arg = match tst with - Itruetest -> reg arg.(0) - | Ifalsetest -> print_string "not "; reg arg.(0) - | Iinttest cmp -> reg arg.(0); intcomp cmp; reg arg.(1) - | Iinttest_imm(cmp, n) -> reg arg.(0); intcomp cmp; print_int n + | Itruetest -> reg ppf arg.(0) + | Ifalsetest -> fprintf ppf "not %a" reg arg.(0) + | Iinttest cmp -> fprintf ppf "%a%s%a" reg arg.(0) (intcomp cmp) reg arg.(1) + | Iinttest_imm(cmp, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intcomp cmp) n | Ifloattest(cmp, neg) -> - if neg then print_string "not "; - reg arg.(0); floatcomp cmp; reg arg.(1) - | Ieventest -> reg arg.(0); print_string " & 1 == 0" - | Ioddtest -> reg arg.(0); print_string " & 1 == 1" + fprintf ppf "%s%a%s%a" + (if neg then "not " else "") + reg arg.(0) (floatcomp cmp) reg arg.(1) + | Ieventest -> fprintf ppf "%a & 1 == 0" reg arg.(0) + | Ioddtest -> fprintf ppf "%a & 1 == 1" reg arg.(0) let print_live = ref false -let operation op arg res = - if Array.length res > 0 then begin regs res; print_string " := " end; +let operation op arg ppf res = + if Array.length res > 0 then fprintf ppf "%a := " regs res; match op with - Imove -> regs arg - | Ispill -> regs arg; print_string " (spill)" - | Ireload -> regs arg; print_string " (reload)" - | Iconst_int n -> print_string(Nativeint.to_string n) - | Iconst_float s -> print_string s - | Iconst_symbol s -> printf "\"%s\"" s - | Icall_ind -> print_string "call "; regs arg - | Icall_imm lbl -> - printf "call \"%s\" " lbl; - regs arg - | Itailcall_ind -> print_string "tailcall "; regs arg - | Itailcall_imm lbl -> - printf "tailcall \"%s\" " lbl; - regs arg + | Imove -> regs ppf arg + | Ispill -> fprintf ppf "%a (spill)" regs arg + | Ireload -> fprintf ppf "%a (reload)" regs arg + | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) + | Iconst_float s -> fprintf ppf "%s" s + | Iconst_symbol s -> fprintf ppf "\"%s\"" s + | Icall_ind -> fprintf ppf "call %a" regs arg + | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg + | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg + | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg | Iextcall(lbl, alloc) -> - printf "extcall \"%s\" " lbl; - regs arg; - if not alloc then print_string " (noalloc)" + fprintf ppf "extcall \"%s\" %a%s" lbl regs arg + (if not alloc then "" else " (noalloc)") | Istackoffset n -> - printf "offset stack %i" n + fprintf ppf "offset stack %i" n | Iload(chunk, addr) -> - Printcmm.chunk chunk; - print_string "["; - Arch.print_addressing reg addr arg; - print_string "]" + fprintf ppf "%s[%a]" + (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg | Istore(chunk, addr) -> - Printcmm.chunk chunk; - print_string "["; - Arch.print_addressing reg addr (Array.sub arg 1 (Array.length arg - 1)); - print_string "] := "; - reg arg.(0) - | Ialloc n -> printf "alloc %i" n - | Iintop(op) -> reg arg.(0); intop op; reg arg.(1) - | Iintop_imm(op, n) -> reg arg.(0); intop op; print_int n - | Inegf -> print_string "-f "; reg arg.(0) - | Iabsf -> print_string "absf "; reg arg.(0) - | Iaddf -> reg arg.(0); print_string " +f "; reg arg.(1) - | Isubf -> reg arg.(0); print_string " -f "; reg arg.(1) - | Imulf -> reg arg.(0); print_string " *f "; reg arg.(1) - | Idivf -> reg arg.(0); print_string " /f "; reg arg.(1) - | Ifloatofint -> print_string "floatofint "; reg arg.(0) - | Iintoffloat -> print_string "intoffloat "; reg arg.(0) + fprintf ppf "%s[%a] := %a" + (Printcmm.chunk chunk) + (Arch.print_addressing reg addr) + (Array.sub arg 1 (Array.length arg - 1)) + reg arg.(0) + | Ialloc n -> fprintf ppf "alloc %i" n + | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) + | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n + | Inegf -> fprintf ppf "-f %a" reg arg.(0) + | Iabsf -> fprintf ppf "absf %a" reg arg.(0) + | Iaddf -> fprintf ppf "%a +f %a" reg arg.(0) reg arg.(1) + | Isubf -> fprintf ppf "%a -f %a" reg arg.(0) reg arg.(1) + | Imulf -> fprintf ppf "%a *f %a" reg arg.(0) reg arg.(1) + | Idivf -> fprintf ppf "%a /f %a" reg arg.(0) reg arg.(1) + | Ifloatofint -> fprintf ppf "floatofint %a" reg arg.(0) + | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0) | Ispecific op -> - Arch.print_specific_operation reg op arg + Arch.print_specific_operation reg op ppf arg -let rec instruction ppf i = +let rec instr ppf i = if !print_live then begin - printf "@[<1>{"; - regsetaddr i.live; - if Array.length i.arg > 0 then begin - printf "@ +@ "; regs i.arg - end; - printf "}@]@,"; + fprintf ppf "@[<1>{%a" regsetaddr i.live; + if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg; + fprintf ppf "}@]@,"; end; begin match i.desc with - Iend -> () + | Iend -> () | Iop op -> - operation op i.arg i.res + operation op i.arg ppf i.res | Ireturn -> - print_string "return "; regs i.arg + fprintf ppf "return %a" regs i.arg | Iifthenelse(tst, ifso, ifnot) -> - printf "@[<v 2>if "; test tst i.arg; - printf " then@,%a" instruction ifso; + fprintf ppf "@[<v 2>if %a then@,%a" (test tst) i.arg instr ifso; begin match ifnot.desc with - Iend -> () - | _ -> printf "@;<0 -2>else@,%a" instruction ifnot + | Iend -> () + | _ -> fprintf ppf "@;<0 -2>else@,%a" instr ifnot end; - printf "@;<0 -2>endif@]" + fprintf ppf "@;<0 -2>endif@]" | Iswitch(index, cases) -> - printf "switch %a" register i.arg.(0); + fprintf ppf "switch %a" reg i.arg.(0); for i = 0 to Array.length cases - 1 do - printf "@,@[<v 2>@["; + fprintf ppf "@,@[<v 2>@["; for j = 0 to Array.length index - 1 do - if index.(j) = i then printf "case %i:@," j + if index.(j) = i then fprintf ppf "case %i:@," j done; - printf "@]@,%a@]" instruction cases.(i) + fprintf ppf "@]@,%a@]" instr cases.(i) done; - printf "@,endswitch" + fprintf ppf "@,endswitch" | Iloop(body) -> - printf "@[<v 2>loop@,%a@;<0 -2>endloop@]" instruction body + fprintf ppf "@[<v 2>loop@,%a@;<0 -2>endloop@]" instr body | Icatch(body, handler) -> - printf "@[<v 2>catch@,%a@;<0 -2>with@,%a@;<0 -2>endcatch@]" - instruction body instruction handler + fprintf ppf "@[<v 2>catch@,%a@;<0 -2>with@,%a@;<0 -2>endcatch@]" + instr body instr handler | Iexit -> - print_string "exit" + fprintf ppf "exit" | Itrywith(body, handler) -> - printf "@[<v 2>try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" - instruction body instruction handler + fprintf ppf "@[<v 2>try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" + instr body instr handler | Iraise -> - printf "raise %a" register i.arg.(0) + fprintf ppf "raise %a" reg i.arg.(0) end; begin match i.next.desc with Iend -> () - | _ -> printf "@,%a" instruction i.next + | _ -> fprintf ppf "@,%a" instr i.next end -let functiondecl ppf f = - printf "@[<v 2>%s(" f.fun_name; - regs f.fun_args; - printf ")@,%a@]" instruction f.fun_body +let fundecl ppf f = + fprintf ppf "@[<v 2>%s(%a)@,%a@]" + f.fun_name regs f.fun_args instr f.fun_body -let phase msg f = - printf "*** %s@.%a@." msg functiondecl f +let phase msg ppf f = + fprintf ppf "*** %s@.%a@." msg fundecl f -let interference r = +let interference ppf r = let interf ppf = List.iter - (fun r -> printf "@ %a" register r) + (fun r -> fprintf ppf "@ %a" reg r) r.interf in - printf "@[<2>%a:%t@]@." register r interf + fprintf ppf "@[<2>%a:%t@]@." reg r interf -let interferences () = - printf "*** Interferences@."; - List.iter interference (Reg.all_registers()) +let interferences ppf () = + fprintf ppf "*** Interferences@."; + List.iter (interference ppf) (Reg.all_registers()) -let preference r = +let preference ppf r = let prefs ppf = List.iter - (fun (r, w) -> printf "@ %a weight %i" register r w) + (fun (r, w) -> fprintf ppf "@ %a weight %i" reg r w) r.prefer in - printf "@[<2>%a: %t@]@." register r prefs - -let preferences () = - printf "*** Preferences@."; - List.iter preference (Reg.all_registers()) + fprintf ppf "@[<2>%a: %t@]@." reg r prefs -let fundecl d = printf "%a" functiondecl d -let instr i = printf "%a" instruction i +let preferences ppf () = + fprintf ppf "*** Preferences@."; + List.iter (preference ppf) (Reg.all_registers()) diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli index 23ddf23db..28328707c 100644 --- a/asmcomp/printmach.mli +++ b/asmcomp/printmach.mli @@ -14,16 +14,18 @@ (* Pretty-printing of pseudo machine code *) -val reg: Reg.t -> unit -val regs: Reg.t array -> unit -val regset: Reg.Set.t -> unit -val regsetaddr: Reg.Set.t -> unit -val operation: Mach.operation -> Reg.t array -> Reg.t array -> unit -val test: Mach.test -> Reg.t array -> unit -val instr: Mach.instruction -> unit -val fundecl: Mach.fundecl -> unit -val phase: string -> Mach.fundecl -> unit -val interferences: unit -> unit -val preferences: unit -> unit +open Format + +val reg: formatter -> Reg.t -> unit +val regs: formatter -> Reg.t array -> unit +val regset: formatter -> Reg.Set.t -> unit +val regsetaddr: formatter -> Reg.Set.t -> unit +val operation: Mach.operation -> Reg.t array -> formatter -> Reg.t array -> unit +val test: Mach.test -> formatter -> Reg.t array -> unit +val instr: formatter -> Mach.instruction -> unit +val fundecl: formatter -> Mach.fundecl -> unit +val phase: string -> formatter -> Mach.fundecl -> unit +val interferences: formatter -> unit -> unit +val preferences: formatter -> unit -> unit val print_live: bool ref diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml index e47d9773c..8c7335c25 100644 --- a/asmcomp/sparc/arch.ml +++ b/asmcomp/sparc/arch.ml @@ -14,7 +14,7 @@ (* Specific operations for the Sparc processor *) -open Formatmsg +open Format type specific_operation = unit (* None worth mentioning *) @@ -47,14 +47,14 @@ let num_args_addressing = function (* Printing operations and addressing modes *) -let print_addressing printreg addr arg = +let print_addressing printreg addr ppf arg = match addr with - Ibased(s, n) -> - printf "\"%s\"" s; - if n <> 0 then printf " + %i" n + | Ibased(s, n) -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "\"%s\"%s" s idx | Iindexed n -> - printreg arg.(0); - if n <> 0 then printf " + %i" n + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx -let print_specific_operation printreg op arg = +let print_specific_operation printreg op ppf arg = Misc.fatal_error "Arch_sparc.print_specific_operation" diff --git a/asmrun/.depend b/asmrun/.depend index 69d70b2e7..205c96916 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -57,9 +57,9 @@ freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/stacks.h \ - ../byterun/memory.h + ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/stacks.h hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/memory.h ../byterun/gc.h \ @@ -131,11 +131,11 @@ parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ printexc.o: printexc.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h -roots.o: roots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h stack.h \ - ../byterun/roots.h +roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h stack.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/memory.h \ @@ -222,9 +222,9 @@ freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/stacks.h \ - ../byterun/memory.h + ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/stacks.h hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/memory.h ../byterun/gc.h \ @@ -296,11 +296,11 @@ parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ printexc.d.o: printexc.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h -roots.d.o: roots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h stack.h \ - ../byterun/roots.h +roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h stack.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/memory.h \ @@ -387,9 +387,9 @@ freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/stacks.h \ - ../byterun/memory.h + ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/stacks.h hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/memory.h ../byterun/gc.h \ @@ -461,11 +461,11 @@ parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ printexc.p.o: printexc.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h -roots.p.o: roots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h stack.h \ - ../byterun/roots.h +roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h stack.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/memory.h \ diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 64139686c..84d96f5f5 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/byterun/.depend b/byterun/.depend index ce3b060da..73ae922aa 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -36,8 +36,8 @@ floats.o: floats.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ freelist.o: freelist.c config.h ../config/m.h ../config/s.h freelist.h \ misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h gc_ctrl.o: gc_ctrl.c alloc.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h compact.h custom.h gc.h gc_ctrl.h major_gc.h \ - freelist.h minor_gc.h stacks.h memory.h + ../config/s.h mlvalues.h compact.h custom.h finalise.h roots.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h stacks.h hash.o: hash.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ custom.h memory.h gc.h major_gc.h freelist.h minor_gc.h instrtrace.o: instrtrace.c @@ -106,7 +106,8 @@ terminfo.o: terminfo.c config.h ../config/m.h ../config/s.h alloc.h \ misc.h mlvalues.h fail.h io.h weak.o: weak.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h -wincmdline.o: wincmdline.c +win32.o: win32.c signals.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h alloc.d.o: alloc.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h minor_gc.h \ stacks.h @@ -145,8 +146,8 @@ floats.d.o: floats.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h freelist.h \ misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h gc_ctrl.d.o: gc_ctrl.c alloc.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h compact.h custom.h gc.h gc_ctrl.h major_gc.h \ - freelist.h minor_gc.h stacks.h memory.h + ../config/s.h mlvalues.h compact.h custom.h finalise.h roots.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h stacks.h hash.d.o: hash.c mlvalues.h config.h ../config/m.h ../config/s.h misc.h \ custom.h memory.h gc.h major_gc.h freelist.h minor_gc.h instrtrace.d.o: instrtrace.c instruct.h misc.h config.h ../config/m.h \ @@ -216,4 +217,5 @@ terminfo.d.o: terminfo.c config.h ../config/m.h ../config/s.h alloc.h \ misc.h mlvalues.h fail.h io.h weak.d.o: weak.c alloc.h misc.h config.h ../config/m.h ../config/s.h \ mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h minor_gc.h -wincmdline.d.o: wincmdline.c +win32.d.o: win32.c signals.h misc.h config.h ../config/m.h ../config/s.h \ + mlvalues.h diff --git a/debugger/.depend b/debugger/.depend index 68b81d207..4f59129ed 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -126,10 +126,10 @@ primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi printval.cmo: debugcom.cmi ../toplevel/genprintval.cmi ../utils/misc.cmi \ parser_aux.cmi ../typing/path.cmi ../typing/printtyp.cmi \ - ../typing/types.cmi printval.cmi + ../bytecomp/symtable.cmi ../typing/types.cmi printval.cmi printval.cmx: debugcom.cmx ../toplevel/genprintval.cmx ../utils/misc.cmx \ parser_aux.cmi ../typing/path.cmx ../typing/printtyp.cmx \ - ../typing/types.cmx printval.cmi + ../bytecomp/symtable.cmx ../typing/types.cmx printval.cmi program_loading.cmo: debugger_config.cmi input_handling.cmi ../utils/misc.cmi \ parameters.cmi primitives.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \ program_loading.cmi diff --git a/driver/main.ml b/driver/main.ml index 139acd118..46784805d 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -102,7 +102,6 @@ module Options = Main_args.Make_options (struct end) let main () = -(* A supprimer Formatmsg.set_output Format.err_formatter;*) try Arg.parse Options.list anonymous usage; if !make_archive then begin diff --git a/driver/optcompile.ml b/driver/optcompile.ml index ccc6e13be..e1e54f4b6 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -132,7 +132,7 @@ let implementation ppf sourcefile = +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda +++ Simplif.simplify_lambda +++ print_if ppf Clflags.dump_lambda Printlambda.lambda - ++ Asmgen.compile_implementation prefixname; + ++ Asmgen.compile_implementation prefixname ppf; Compilenv.save_unit_info (prefixname ^ ".cmx"); remove_preprocessed inputfile diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 5a11931f3..f5c23fc6d 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -42,13 +42,13 @@ let report_error ppf exn = | Translcore.Error(loc, err) -> Location.print ppf loc; Translcore.report_error ppf err | Compilenv.Error code -> - Compilenv.report_error code + Compilenv.report_error ppf code | Asmgen.Error code -> - Asmgen.report_error code + Asmgen.report_error ppf code | Asmlink.Error code -> - Asmlink.report_error code + Asmlink.report_error ppf code | Asmlibrarian.Error code -> - Asmlibrarian.report_error code + Asmlibrarian.report_error ppf code | Sys_error msg -> fprintf ppf "I/O error: %s" msg | Typeclass.Error(loc, err) -> diff --git a/driver/optmain.ml b/driver/optmain.ml index e54c7a5a7..62e8e655e 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -151,7 +151,7 @@ let main () = end else if not !compile_only && !objfiles <> [] then begin Optcompile.init_path(); - Asmlink.link (List.rev !objfiles) + Asmlink.link ppf (List.rev !objfiles) end; exit 0 with x -> diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index 9b04d7a12..fed04b50b 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -6,13 +6,14 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ ../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h -mmap_stub.o: mmap_stub.c bigarray.h ../../byterun/mlvalues.h \ +mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/mlvalues.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h \ ../../byterun/custom.h ../../byterun/fail.h ../../byterun/sys.h -mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/mlvalues.h \ +mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/mlvalues.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h \ - ../../byterun/custom.h ../../byterun/fail.h ../../byterun/sys.h + ../../byterun/custom.h ../../byterun/fail.h ../../byterun/sys.h \ + ../unix/unixsupport.h bigarray.cmo: bigarray.cmi bigarray.cmx: bigarray.cmi diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile index 690f5fd50..357a890f5 100644 --- a/otherlibs/bigarray/Makefile +++ b/otherlibs/bigarray/Makefile @@ -67,7 +67,7 @@ clean: partialclean $(CAMLOPT) -c $(COMPFLAGS) $< depend: - gcc -MM $(CFLAGS) *.c > .depend + gcc -MM -I../../byterun -I../unix *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index c455e78e3..cac4b48d6 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -2,8 +2,8 @@ nat_stubs.o: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h big_int.cmi: nat.cmi num.cmi: big_int.cmi nat.cmi ratio.cmi diff --git a/parsing/printast.ml b/parsing/printast.ml index eef902814..fc8d71edf 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -13,68 +13,67 @@ (* $Id$ *) open Asttypes;; -open Formatmsg;; +open Format;; open Location;; open Parsetree;; let fmt_location f loc = if loc.loc_ghost then - Format.fprintf f "(%d,%d) ghost" loc.loc_start loc.loc_end + fprintf f "(%d,%d) ghost" loc.loc_start loc.loc_end else - Format.fprintf f "(%d,%d)" loc.loc_start loc.loc_end + fprintf f "(%d,%d)" loc.loc_start loc.loc_end ;; let rec fmt_longident_aux f x = match x with - | Longident.Lident (s) -> Format.fprintf f "%s" s; - | Longident.Ldot (y, s) -> Format.fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; | Longident.Lapply (y, z) -> - Format.fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; ;; -let fmt_longident f x = Format.fprintf f "\"%a\"" fmt_longident_aux x;; +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;; let fmt_constant f x = match x with - | Const_int (i) -> Format.fprintf f "Const_int %d" i; - | Const_char (c) -> Format.fprintf f "Const_char %02x" (Char.code c); + | Const_int (i) -> fprintf f "Const_int %d" i; + | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); | Const_string (s) -> - Format.fprintf f "Const_string \"%s\"" (String.escaped s); - | Const_float (s) -> Format.fprintf f "Const_float %s" s; + fprintf f "Const_string \"%s\"" (String.escaped s); + | Const_float (s) -> fprintf f "Const_float %s" s; ;; let fmt_mutable_flag f x = match x with - | Immutable -> Format.fprintf f "Immutable"; - | Mutable -> Format.fprintf f "Mutable"; + | Immutable -> fprintf f "Immutable"; + | Mutable -> fprintf f "Mutable"; ;; let fmt_virtual_flag f x = match x with - | Virtual -> Format.fprintf f "Virtual"; - | Concrete -> Format.fprintf f "Concrete"; + | Virtual -> fprintf f "Virtual"; + | Concrete -> fprintf f "Concrete"; ;; let fmt_rec_flag f x = match x with - | Nonrecursive -> Format.fprintf f "Nonrec"; - | Recursive -> Format.fprintf f "Rec"; - | Default -> Format.fprintf f "Default"; + | Nonrecursive -> fprintf f "Nonrec"; + | Recursive -> fprintf f "Rec"; + | Default -> fprintf f "Default"; ;; let fmt_direction_flag f x = match x with - | Upto -> Format.fprintf f "Up"; - | Downto -> Format.fprintf f "Down"; + | Upto -> fprintf f "Up"; + | Downto -> fprintf f "Down"; ;; let fmt_private_flag f x = match x with - | Public -> Format.fprintf f "Public"; - | Private -> Format.fprintf f "Private"; + | Public -> fprintf f "Public"; + | Private -> fprintf f "Private"; ;; -open Format let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) diff --git a/tools/Makefile b/tools/Makefile index c5615cc25..51c9c76e0 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -27,7 +27,7 @@ all: ocamldep ocamlprof ocamlcp ocamlmktop ocaml299to3 # The dependency generator CAMLDEP=ocamldep.cmo -CAMLDEP_IMPORTS=misc.cmo formatmsg.cmo config.cmo clflags.cmo terminfo.cmo \ +CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo @@ -43,7 +43,7 @@ install:: # The profiler CSLPROF=ocamlprof.cmo -CSLPROF_IMPORTS=misc.cmo formatmsg.cmo config.cmo clflags.cmo terminfo.cmo \ +CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo @@ -114,7 +114,7 @@ DUMPOBJ=opnames.cmo dumpobj.cmo dumpobj: $(DUMPOBJ) $(CAMLC) $(LINKFLAGS) -o dumpobj \ - misc.cmo formatmsg.cmo tbl.cmo config.cmo ident.cmo \ + misc.cmo tbl.cmo config.cmo ident.cmo \ opcodes.cmo bytesections.cmo $(DUMPOBJ) clean:: diff --git a/tools/Makefile.Mac b/tools/Makefile.Mac index 3ac4b8dcb..65c35254e 100644 --- a/tools/Makefile.Mac +++ b/tools/Makefile.Mac @@ -23,7 +23,7 @@ all Ä ocamldep ocamldumpobj objinfo primreq keywords # The dependency generator -CAMLDEP_IMPORTS = misc.cmo formatmsg.cmo config.cmo clflags.cmo terminfo.cmo ¶ +CAMLDEP_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶ linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo ¶ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo @@ -41,7 +41,7 @@ install ÄÄ # The profiler (not available on MacOS for the moment) # #CSLPROF = ocamlprof.cmo -#CSLPROF_IMPORTS = misc.cmo formatmsg.cmo config.cmo clflags.cmo terminfo.cmo ¶ +#CSLPROF_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶ # linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo ¶ # syntaxerr.cmo parser.cmo lexer.cmo parse.cmo # @@ -67,7 +67,7 @@ DUMPOBJ = opnames.cmo dumpobj.cmo ocamldumpobj Ä {DUMPOBJ} {CAMLC} {LINKFLAGS} -o ocamldumpobj ¶ - misc.cmo formatmsg.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo ¶ + misc.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo ¶ bytesections.cmo {DUMPOBJ} clean ÄÄ diff --git a/tools/Makefile.nt b/tools/Makefile.nt index c26dbf557..5d25ce4c0 100644 --- a/tools/Makefile.nt +++ b/tools/Makefile.nt @@ -27,7 +27,7 @@ all: ocamldep ocamlprof ocamlcp.exe ocamlmktop.exe primreq # The dependency generator CAMLDEP=ocamldep.cmo -CAMLDEP_IMPORTS=misc.cmo formatmsg.cmo config.cmo clflags.cmo terminfo.cmo \ +CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo @@ -45,7 +45,7 @@ beforedepend:: ocamldep.ml # The profiler CSLPROF=ocamlprof.cmo -CSLPROF_IMPORTS=misc.cmo formatmsg.cmo config.cmo clflags.cmo terminfo.cmo \ +CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo @@ -98,7 +98,7 @@ DUMPOBJ=opnames.cmo dumpobj.cmo dumpobj: $(DUMPOBJ) $(CAMLC) $(LINKFLAGS) -o dumpobj \ - misc.cmo formatmsg.cmo tbl.cmo config.cmo ident.cmo \ + misc.cmo tbl.cmo config.cmo ident.cmo \ opcodes.cmo bytesections.cmo $(DUMPOBJ) clean:: diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 6e5ff504c..a80491433 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -317,5 +317,4 @@ let run_script ppf name args = Obj.truncate (Obj.repr Sys.argv) len; Compile.init_path(); toplevel_env := Compile.initial_env(); -(* Formatmsg.set_output Format.err_formatter;*) use_silently ppf name diff --git a/utils/tbl.ml b/utils/tbl.ml index df24455ad..b00b2f7c6 100644 --- a/utils/tbl.ml +++ b/utils/tbl.ml @@ -95,16 +95,10 @@ let rec iter f = function | Node(l, v, d, r, _) -> iter f l; f v d; iter f r -open Formatmsg +open Format -let print print_key print_data tbl = - open_hvbox 2; - print_string "[["; - iter (fun k d -> - open_box 2; - print_key k; print_string " ->"; print_space(); - print_data d; print_string ";"; - close_box(); print_space()) - tbl; - print_string "]]"; - close_box() +let print print_key print_data ppf tbl = + let print_tbl ppf tbl = + iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) + tbl in + fprintf ppf "@[<hv 2>[[%a]]@]" print_tbl tbl diff --git a/utils/tbl.mli b/utils/tbl.mli index 718515030..ddeaa79d6 100644 --- a/utils/tbl.mli +++ b/utils/tbl.mli @@ -24,4 +24,7 @@ val mem: 'a -> ('a, 'b) t -> bool val remove: 'a -> ('a, 'b) t -> ('a, 'b) t val iter: ('a -> 'b -> 'c) -> ('a, 'b) t -> unit -val print: ('a -> unit) -> ('b -> unit) -> ('a, 'b) t -> unit +open Format + +val print: (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) -> + formatter -> ('a, 'b) t -> unit |