Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Suppression de Formatmsg, réécriture des messages à l'aide de Format.fprintf 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3123 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Pierre Weis 2000-04-21 08:13:22 +00:00
parent da86545caa
commit 9abfff060e
42 changed files with 602 additions and 627 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
asmcomp/alpha/arch.ml
View File

@ -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) *)

41
asmcomp/arm/arch.ml
View File

@ -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)

79
asmcomp/asmgen.ml
View File

@ -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

8
asmcomp/asmgen.mli
View File

@ -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

10
asmcomp/asmlibrarian.ml
View File

@ -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

4
asmcomp/asmlibrarian.mli
View File

@ -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

69
asmcomp/asmlink.ml
View File

@ -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"

6
asmcomp/asmlink.mli
View File

@ -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

8
asmcomp/codegen.ml
View File

@ -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

14
asmcomp/compilenv.ml
View File

@ -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

2
asmcomp/compilenv.mli
View File

@ -76,4 +76,4 @@ type error =
exception Error of error
val report_error: error -> unit
val report_error: Format.formatter -> error -> unit

22
asmcomp/hppa/arch.ml
View File

@ -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)

86
asmcomp/i386/arch.ml
View File

@ -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))

4
asmcomp/liveness.ml
View File

@ -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

4
asmcomp/liveness.mli
View File

@ -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

16
asmcomp/mips/arch.ml
View File

@ -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"

32
asmcomp/power/arch.ml
View File

@ -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)"

234
asmcomp/printcmm.ml
View File

@ -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_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 dl =
let items ppf = List.iter (fun d -> print_space(); data_item d) dl in
printf "@[<hv 1>(data%t)@]" items
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 = function
Cfunction f -> fundecl f
| Cdata dl -> data dl
let phrase ppf = function
| Cfunction f -> fundecl ppf f
| Cdata dl -> data ppf dl

20
asmcomp/printcmm.mli
View File

@ -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

54
asmcomp/printlinear.ml
View File

@ -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

5
asmcomp/printlinear.mli
View File

@ -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

262
asmcomp/printmach.ml
View File

@ -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
fprintf ppf "@[<2>%a: %t@]@." reg r prefs
let preferences () =
printf "*** Preferences@.";
List.iter preference (Reg.all_registers())
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())

24
asmcomp/printmach.mli
View File

@ -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

16
asmcomp/sparc/arch.ml
View File

@ -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"

48
asmrun/.depend
View File

@ -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 \

BIN
boot/ocamllex
View File

Binary file not shown.

14
byterun/.depend
View File

@ -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

4
debugger/.depend
View File

@ -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

1
driver/main.ml
View File

@ -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

2
driver/optcompile.ml
View File

@ -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

8
driver/opterrors.ml
View File

@ -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) ->

2
driver/optmain.ml
View File

@ -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 ->

9
otherlibs/bigarray/.depend
View File

@ -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 \
../../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 \
../../byterun/config.h ../../byterun/../config/m.h \
../../byterun/../config/s.h ../../byterun/misc.h \
../../byterun/custom.h ../../byterun/fail.h ../../byterun/sys.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 \
../unix/unixsupport.h
bigarray.cmo: bigarray.cmi
bigarray.cmx: bigarray.cmi

2
otherlibs/bigarray/Makefile
View File

@ -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

4
otherlibs/num/.depend
View File

@ -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

45
parsing/printast.ml
View File

@ -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 (*...*)

6
tools/Makefile
View File

@ -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::

6
tools/Makefile.Mac
View File

@ -23,7 +23,7 @@ all
# 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 ÄÄ

6
tools/Makefile.nt
View File

@ -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::

1
toplevel/toploop.ml
View File

@ -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

18
utils/tbl.ml
View File

@ -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

5
utils/tbl.mli
View File

@ -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