diff options
41 files changed, 2584 insertions, 566 deletions
diff --git a/asmcomp/arch_alpha.ml b/asmcomp/arch_alpha.ml index ec9b42cd4..536f5caeb 100644 --- a/asmcomp/arch_alpha.ml +++ b/asmcomp/arch_alpha.ml @@ -2,15 +2,17 @@ open Format -type specific_operation = - Iadd4 | Iadd8 | Isub4 | Isub8 (* Scaled adds and subs *) - (* Addressing modes *) type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) +(* Specific operations *) + +type specific_operation = + Iadd4 | Iadd8 | Isub4 | Isub8 (* Scaled adds and subs *) + (* Sizes, endianness *) let big_endian = false @@ -49,4 +51,3 @@ let print_specific_operation printreg op arg = | 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) - diff --git a/asmcomp/arch_i386.ml b/asmcomp/arch_i386.ml index a06f96b99..b58f9b4ab 100644 --- a/asmcomp/arch_i386.ml +++ b/asmcomp/arch_i386.ml @@ -4,11 +4,14 @@ type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) | Iindexed2 of int (* reg + reg + displ *) + | Iscaled of int * int (* reg * scale + displ *) | Iindexed2scaled of int * int (* reg + reg * scale + displ *) type specific_operation = - Ineg (* Integer negate *) - | Ilea of addressing_mode (* Lea gives scaled adds *) + Ilea of addressing_mode (* Lea gives scaled adds *) + | Istore_int of int * addressing_mode (* Store an integer constant *) + | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) (* Sizes, endianness *) @@ -27,12 +30,14 @@ let offset_addressing addr delta = Ibased(s, n) -> Ibased(s, n + delta) | Iindexed n -> Iindexed(n + delta) | Iindexed2 n -> Iindexed2(n + delta) + | Iscaled(scale, n) -> Iscaled(scale, n + delta) | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function Ibased(s, n) -> 0 | Iindexed n -> 1 | Iindexed2 n -> 2 + | Iscaled(scale, n) -> 1 | Iindexed2scaled(scale, n) -> 2 (* Printing operations and addressing modes *) @@ -51,6 +56,9 @@ let print_addressing printreg addr arg = | Iindexed2 n -> printreg arg.(0); print_string " + "; printreg arg.(1); if n <> 0 then begin print_string " + "; print_int n end + | Iscaled(scale, n) -> + printreg arg.(0); print_string " * "; print_int scale; + if n <> 0 then begin print_string " + "; print_int n end | Iindexed2scaled(scale, n) -> printreg arg.(0); print_string " + "; printreg arg.(1); print_string " * "; print_int scale; @@ -58,6 +66,14 @@ let print_addressing printreg addr arg = let print_specific_operation printreg op arg = match op with - Ineg -> print_string "- "; printreg arg.(0) - | Ilea addr -> print_addressing printreg addr arg + Ilea addr -> print_addressing printreg addr arg + | Istore_int(n, addr) -> + print_string "["; print_addressing printreg addr arg; + print_string "] := "; print_int n + | Istore_symbol(lbl, addr) -> + print_string "["; print_addressing printreg addr arg; + print_string "] := \""; print_string lbl; print_string "\"" + | Ioffset_loc(n, addr) -> + print_string "["; print_addressing printreg addr arg; + print_string "] +:= "; print_int n diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml new file mode 100644 index 000000000..1ccc7005f --- /dev/null +++ b/asmcomp/asmgen.ml @@ -0,0 +1,80 @@ +(* From lambda to assembly code *) + +open Format +open Clflags +open Misc +open Cmm + +type error = Assembler_error of string + +exception Error of error + +let rec regalloc fd = + if !dump_live then Printmach.phase "Liveness analysis" fd; + Interf.build_graph fd; + if !dump_interf then Printmach.interferences(); + if !dump_prefer then Printmach.preferences(); + Coloring.allocate_registers(); + if !dump_regalloc then + Printmach.phase "After register allocation" fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + if !dump_reload then + Printmach.phase "After insertion of reloading code" newfd; + if redo_regalloc + then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end + else newfd + +let compile_fundecl fd_cmm = + Reg.reset(); + let fd_sel = Selection.fundecl fd_cmm in + if !dump_selection then + Printmach.phase "After instruction selection" fd_sel; + Liveness.fundecl fd_sel; + if !dump_live then Printmach.phase "Liveness analysis" fd_sel; + let fd_spill = Spill.fundecl fd_sel in + Liveness.fundecl fd_spill; + if !dump_spill then + Printmach.phase "After spilling" fd_spill; + let fd_split = Split.fundecl fd_spill in + Liveness.fundecl fd_split; + if !dump_split then + Printmach.phase "After live range splitting" fd_split; + let fd_reload = regalloc fd_split in + let fd_linear = Linearize.fundecl fd_reload in + if !dump_linear then begin + print_string "*** Linearized code"; print_newline(); + Printlinear.fundecl fd_linear; print_newline() + end; + Emit.fundecl fd_linear + +let compile_phrase p = + if !dump_cmm then begin Printcmm.phrase p; print_newline() end; + match p with + Cfunction fd -> compile_fundecl fd + | Cdata dl -> Emit.data dl + +let compile_implementation prefixname lam = + let asmfile = + if !assembler_only then prefixname ^ ".s" else temp_file "camlasm" ".s" in + let oc = open_out asmfile in + begin try + Emitaux.output_channel := oc; + Emit.begin_assembly(); + List.iter compile_phrase (Cmmgen.compunit (Closure.intro lam)); + Emit.end_assembly(); + close_out oc + with x -> + close_out oc; (*remove_file asmfile;*) raise x + end; + if !assembler_only then () else begin + if Proc.assemble_file asmfile (prefixname ^ ".o") <> 0 + then raise(Error(Assembler_error asmfile)) + else remove_file asmfile + end + +(* Error report *) + +let report_error = function + Assembler_error file -> + print_string "Assembler error, input left in file "; + print_string file diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli new file mode 100644 index 000000000..5d973d05f --- /dev/null +++ b/asmcomp/asmgen.mli @@ -0,0 +1,10 @@ +(* From lambda to assembly code *) + +val compile_implementation: string -> Lambda.lambda -> unit +val compile_phrase: Cmm.phrase -> unit + +type error = Assembler_error of string +exception Error of error +val report_error: error -> unit + + diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml new file mode 100644 index 000000000..d80ecf3c8 --- /dev/null +++ b/asmcomp/asmlink.ml @@ -0,0 +1,208 @@ +(* Link a set of .cmx/.o files and produce an executable *) + +open Sys +open Misc +open Config +open Compilenv + +type error = + File_not_found of string + | Not_an_object_file of string + | Inconsistent_interface of string * string * string + | Inconsistent_implementation of string * string * string + | Assembler_error of string + | Linking_error + +exception Error of error + +(* Consistency check between interfaces and implementations *) + +let crc_interfaces = (Hashtbl.new 17 : (string, string * int) Hashtbl.t) +let crc_implementations = (Hashtbl.new 17 : (string, string * int) Hashtbl.t) + +let check_consistency file_name unit crc = + List.iter + (fun (name, crc) -> + try + let (auth_name, auth_crc) = Hashtbl.find crc_interfaces name in + if crc <> auth_crc then + raise(Error(Inconsistent_interface(name, file_name, auth_name))) + with Not_found -> + Hashtbl.add crc_interfaces name (file_name, crc)) + unit.ui_interfaces; + List.iter + (fun (name, crc) -> + try + let (auth_name, auth_crc) = Hashtbl.find crc_implementations name in + if crc <> auth_crc then + raise(Error(Inconsistent_implementation(name, file_name, auth_name))) + with Not_found -> + Hashtbl.add crc_implementations name (file_name, crc)) + ((unit.ui_name, crc) :: unit.ui_imports) + +(* First pass: determine which units are needed *) + +module StringSet = + Set.Make(struct + type t = string + let compare = compare + end) + +let missing_globals = ref StringSet.empty + +let is_required name = + StringSet.mem name !missing_globals + +let add_required (name, crc) = + missing_globals := StringSet.add name !missing_globals + +let remove_required name = + missing_globals := StringSet.remove name !missing_globals + +let scan_file tolink obj_name = + let file_name = + try + find_in_path !load_path obj_name + with Not_found -> + raise(Error(File_not_found obj_name)) in + let ic = open_in_bin file_name in + try + let buffer = String.create (String.length cmx_magic_number) in + really_input ic buffer 0 (String.length cmx_magic_number); + if buffer = cmx_magic_number then begin + (* This is a .cmx file. It must be linked in any case. + Read the infos to see which modules it + requires. *) + let info = (input_value ic : unit_infos) in + let crc = input_binary_int ic in + close_in ic; + check_consistency file_name info crc; + List.iter add_required info.ui_imports; + info :: tolink + end + else if buffer = cmxa_magic_number then begin + (* This is an archive file. Each unit contained in it will be linked + in only if needed. *) + let info_crc_list = (input_value ic : (unit_infos * int) list) in + close_in ic; + List.fold_left + (fun reqd (info, crc) -> + if is_required info.ui_name then begin + check_consistency file_name info crc; + remove_required info.ui_name; + List.iter add_required info.ui_imports; + info :: reqd + end else + reqd) + tolink info_crc_list + end + else raise(Error(Not_an_object_file file_name)) + with x -> + close_in ic; raise x + +(* Second pass: generate the startup file and link it with everything else *) + +module IntSet = Set.Make( + struct + type t = int + let compare = compare + end) + +let make_startup_file filename info_list = + let oc = open_out filename in + Emitaux.output_channel := oc; + Compilenv.reset "startup" 0; (* 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); + let apply_functions = ref IntSet.empty in + let curry_functions = ref IntSet.empty in + List.iter + (fun info -> + List.iter + (fun n -> apply_functions := IntSet.add n !apply_functions) + info.ui_apply_fun; + List.iter + (fun n -> curry_functions := IntSet.add n !curry_functions) + info.ui_curry_fun) + info_list; + IntSet.iter + (fun n -> Asmgen.compile_phrase(Cmmgen.apply_function n)) + !apply_functions; + IntSet.iter + (fun n -> List.iter Asmgen.compile_phrase (Cmmgen.curry_function n)) + !curry_functions; + Asmgen.compile_phrase(Cmmgen.global_table name_list); + Asmgen.compile_phrase(Cmmgen.frame_table ("startup" :: name_list)); + Emit.end_assembly(); + close_out oc + +let call_linker file_list startup_file = + if Sys.command + (Printf.sprintf + "%s -I%s -o %s %s %s %s -L%s %s %s" + Config.c_compiler + Config.standard_library + !Clflags.exec_name + (String.concat " " (List.rev !Clflags.ccopts)) + (String.concat " " (List.rev file_list)) + startup_file + Config.standard_library + (String.concat " " (List.rev !Clflags.ccobjs)) + Config.c_libraries) <> 0 + then raise(Error Linking_error) + +let object_file_name name = + if Filename.check_suffix name ".cmx" then + Filename.chop_suffix name ".cmx" ^ ".o" + else if Filename.check_suffix name ".cmxa" then + Filename.chop_suffix name ".cmxa" ^ ".a" + else + fatal_error "Asmlink.object_file_name" + +(* Main entry point *) + +let link objfiles = +(** let objfiles = "stdlib.cmxa" :: objfiles in **) + let units_tolink = List.fold_left scan_file [] (List.rev objfiles) in + let startup = temp_file "camlstartup" ".s" in + make_startup_file startup units_tolink; + let startup_obj = temp_file "camlstartup" ".o" in + if Proc.assemble_file startup startup_obj <> 0 then + raise(Error(Assembler_error startup)); + try + call_linker (List.map object_file_name objfiles) startup_obj; + remove_file startup; + remove_file startup_obj + with x -> + remove_file startup_obj; + raise x + +(* Error report *) + +open Format + +let report_error = function + File_not_found name -> + print_string "Cannot find file "; print_string name + | Not_an_object_file name -> + print_string "The file "; print_string name; + print_string " is not a compilation unit description" + | Inconsistent_interface(intf, file1, file2) -> + open_hvbox 0; + print_string "Files "; print_string file1; print_string " and "; + print_string file2; print_space(); + print_string "make inconsistent assumptions over interface "; + print_string intf; + close_box() + | Inconsistent_implementation(intf, file1, file2) -> + open_hvbox 0; + print_string "Files "; print_string file1; print_string " and "; + print_string file2; print_space(); + print_string "make inconsistent assumptions over implementation "; + print_string intf; + close_box() + | Assembler_error file -> + print_string "Error while assembling "; print_string file + | Linking_error -> + print_string "Error during linking" diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli new file mode 100644 index 000000000..2f7ef5cc5 --- /dev/null +++ b/asmcomp/asmlink.mli @@ -0,0 +1,15 @@ +(* Link a set of .cmx/.o files and produce an executable *) + +val link: string list -> unit + +type error = + File_not_found of string + | Not_an_object_file of string + | Inconsistent_interface of string * string * string + | Inconsistent_implementation of string * string * string + | Assembler_error of string + | Linking_error + +exception Error of error + +val report_error: error -> unit diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml new file mode 100644 index 000000000..aad744d12 --- /dev/null +++ b/asmcomp/clambda.ml @@ -0,0 +1,39 @@ +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ulambda = + Uvar of Ident.t + | Uconst of structured_constant + | Udirect_apply of function_label * ulambda list + | Ugeneric_apply of ulambda * ulambda list + | Uclosure of function_label * int * Ident.t list * ulambda * ulambda list + | Ulet of Ident.t * ulambda * ulambda + | Uletrec of (Ident.t * ulambda) list * ulambda + | Uprim of primitive * ulambda list + | Uswitch of ulambda * int array * ulambda array * int array * ulambda array + | Ustaticfail + | Ucatch of ulambda * ulambda + | Utrywith of ulambda * Ident.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + fun_closed: bool } (* True if environment not used *) + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli new file mode 100644 index 000000000..aad744d12 --- /dev/null +++ b/asmcomp/clambda.mli @@ -0,0 +1,39 @@ +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ulambda = + Uvar of Ident.t + | Uconst of structured_constant + | Udirect_apply of function_label * ulambda list + | Ugeneric_apply of ulambda * ulambda list + | Uclosure of function_label * int * Ident.t list * ulambda * ulambda list + | Ulet of Ident.t * ulambda * ulambda + | Uletrec of (Ident.t * ulambda) list * ulambda + | Uprim of primitive * ulambda list + | Uswitch of ulambda * int array * ulambda array * int array * ulambda array + | Ustaticfail + | Ucatch of ulambda * ulambda + | Utrywith of ulambda * Ident.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + fun_closed: bool } (* True if environment not used *) + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml new file mode 100644 index 000000000..6183c351c --- /dev/null +++ b/asmcomp/closure.ml @@ -0,0 +1,275 @@ +(* Introduction of closures, uncurrying, recognition of direct calls *) + +open Misc +open Lambda +open Clambda + +(* Auxiliaries for compiling functions *) + +let rec split_list n l = + if n <= 0 then ([], l) else begin + match l with + [] -> fatal_error "Closure.split_list" + | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) + end + +let rec uncurry_fun = function + Lfunction(param, body) -> + let (params, final_body) = uncurry_fun body in + (param :: params, final_body) + | lam -> ([], lam) + +let rec build_closure_env env_param pos = function + [] -> Tbl.empty + | id :: rem -> + Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) + (build_closure_env env_param (pos+1) rem) + +(* Auxiliaries for compiling recursive definitions *) + +type fun_analysis = + { fa_desc: function_description; + fa_params: Ident.t list; + fa_body: lambda; + fa_cenv: (Ident.t, ulambda) Tbl.t; + fa_clos: ulambda list } + +type rec_approximation = + Rec_function of fun_analysis + | Rec_other of lambda + +(* Uncurry an expression and explicitate closures. + Also return the approximation of the expression. + The approximation environment [fenv] maps idents to approximations. + Idents not bound in [fenv] approximate to [Value_unknown]. + The closure environment [cenv] maps idents to [ulambda] terms. + It is used to substitute environment accesses for free identifiers. *) + +let rec close fenv cenv = function + Lvar id -> + (begin try Tbl.find id cenv with Not_found -> Uvar id end, + begin try Tbl.find id fenv with Not_found -> Value_unknown end) + | Lconst cst -> + (Uconst cst, Value_unknown) + | Lfunction(param, body) as funct -> + close_function fenv cenv (Ident.new "fun") funct + | Lapply(funct, args) -> + let nargs = List.length args in + begin match close fenv cenv funct with + (ufunct, Value_closure(fundesc, approx_res)) + when nargs = fundesc.fun_arity -> + let uargs = close_list fenv cenv args in + let app_args = if fundesc.fun_closed then uargs + else uargs @ [ufunct] in + (Udirect_apply(fundesc.fun_label, app_args), + approx_res) + | (ufunct, Value_closure(fundesc, approx_res)) + when nargs > fundesc.fun_arity -> + let (first_args, rem_args) = split_list fundesc.fun_arity args in + let ufirst_args = close_list fenv cenv first_args in + let app_args = if fundesc.fun_closed then ufirst_args + else ufirst_args @ [ufunct] in + (Ugeneric_apply(Udirect_apply(fundesc.fun_label, app_args), + close_list fenv cenv rem_args), + Value_unknown) + | (ufunct, _) -> + (Ugeneric_apply(ufunct, close_list fenv cenv args), Value_unknown) + end + | Llet(id, lam, body) -> + let (ulam, alam) = close_named fenv cenv id lam in + let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in + (Ulet(id, ulam, ubody), abody) + | Lletrec([id, (Lfunction(_, _) as funct)], body) -> + let funapp = close_analyze_function_rec1 fenv cenv id funct in + let (ufunct, approx) = + close_build_function + (Tbl.add id (Value_closure(funapp.fa_desc, Value_unknown)) fenv) + funapp in + let (ubody, approx) = close (Tbl.add id approx fenv) cenv body in + (Ulet(id, ufunct, ubody), approx) + | Lletrec(decls, body) -> + let rec make_rec_fenv = function + [] -> (fenv, []) + | (id, lam) :: rem -> + let (new_fenv, precomp) = make_rec_fenv rem in + match lam with + Lfunction(param, body) -> + let funapp = close_analyze_function fenv cenv id lam in + (Tbl.add id (Value_closure(funapp.fa_desc, Value_unknown)) + new_fenv, + (id, Rec_function funapp) :: precomp) + | _ -> + (new_fenv, (id, Rec_other lam) :: precomp) in + let (rec_fenv, precomp) = make_rec_fenv decls in + let rec close_decls = function + [] -> (fenv, []) + | (id, pre) :: rem -> + let (new_fenv, urem) = close_decls rem in + match pre with + Rec_function funapp -> + let (ulam, approx) = close_build_function rec_fenv funapp in + (Tbl.add id approx new_fenv, (id, ulam) :: urem) + | Rec_other lam -> + let (ulam, approx) = close rec_fenv cenv lam in + (Tbl.add id approx new_fenv, (id, ulam) :: urem) in + let (body_fenv, udecls) = close_decls precomp in + let (ubody, approx) = close body_fenv cenv body in + (Uletrec(udecls, ubody), approx) + | Lprim(Pgetglobal id, []) -> + (Uprim(Pgetglobal id, []), Compilenv.global_approx id) + | Lprim(Psetglobal id, [lam]) -> + let (ulam, approx) = close fenv cenv lam in + Compilenv.set_global_approx approx; + (Uprim(Psetglobal id, [ulam]), Value_unknown) + | Lprim(Pmakeblock tag, lams) -> + let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in + (Uprim(Pmakeblock tag, ulams), Value_tuple(Array.of_list approxs)) + | Lprim(Pfield n, [lam]) -> + let (ulam, approx) = close fenv cenv lam in + (Uprim(Pfield n, [ulam]), + match approx with + Value_tuple a when n < Array.length a -> a.(n) + | _ -> Value_unknown) + | Lprim(p, args) -> + (Uprim(p, close_list fenv cenv args), Value_unknown) + | Lswitch(arg, nconst, consts, nblock, blocks) -> + let (uarg, _) = close fenv cenv arg in + let (const_index, const_cases) = close_switch fenv cenv nconst consts in + let (block_index, block_cases) = close_switch fenv cenv nblock blocks in + (Uswitch(uarg, const_index, const_cases, block_index, block_cases), + Value_unknown) + | Lstaticfail -> + (Ustaticfail, Value_unknown) + | Lcatch(body, handler) -> + let (ubody, _) = close fenv cenv body in + let (uhandler, _) = close fenv cenv handler in + (Ucatch(ubody, uhandler), Value_unknown) + | Ltrywith(body, id, handler) -> + let (ubody, _) = close fenv cenv body in + let (uhandler, _) = close fenv cenv handler in + (Utrywith(ubody, id, uhandler), Value_unknown) + | Lifthenelse(arg, ifso, ifnot) -> + let (uarg, _) = close fenv cenv arg in + let (uifso, _) = close fenv cenv ifso in + let (uifnot, _) = close fenv cenv ifnot in + (Uifthenelse(uarg, uifso, uifnot), Value_unknown) + | Lsequence(lam1, lam2) -> + let (ulam1, _) = close fenv cenv lam1 in + let (ulam2, approx) = close fenv cenv lam2 in + (Usequence(ulam1, ulam2), approx) + | Lwhile(cond, body) -> + let (ucond, _) = close fenv cenv cond in + let (ubody, _) = close fenv cenv body in + (Uwhile(ucond, ubody), Value_unknown) + | Lfor(id, lo, hi, dir, body) -> + let (ulo, _) = close fenv cenv lo in + let (uhi, _) = close fenv cenv hi in + let (ubody, _) = close fenv cenv body in + (Ufor(id, ulo, uhi, dir, ubody), Value_unknown) + | Lshared(lam, _) -> + close fenv cenv lam + +and close_list fenv cenv = function + [] -> [] + | lam :: rem -> + let (ulam, _) = close fenv cenv lam in + ulam :: close_list fenv cenv rem + +and close_named fenv cenv id = function + Lfunction(param, body) as funct -> + close_function fenv cenv id funct + | lam -> + close fenv cenv lam + +(* Build a function closure with the given name *) + +and close_function fenv cenv id funct = + close_build_function fenv (close_analyze_function fenv cenv id funct) + +(* Return preliminary information for a function closure *) + +and close_analyze_function fenv cenv id funct = + let fv = IdentSet.elements(free_variables funct) in + let label = Compilenv.current_unit_name() ^ "_" ^ Ident.unique_name id in + let (params, body) = uncurry_fun funct in + let arity = List.length params in + let env_param = Ident.new "env" in + let cenv_body = + build_closure_env env_param (if arity > 1 then 3 else 2) fv in + {fa_desc = {fun_label = label; fun_arity = arity; fun_closed = (fv=[])}; + fa_params = params @ [env_param]; + fa_body = body; + fa_cenv = cenv_body; + fa_clos = close_list fenv cenv (List.map (fun id -> Lvar id) fv)} + +(* Same, but for a simply recursive function. In this case, the closure for + the function itself is in its environment parameter. *) + +and close_analyze_function_rec1 fenv cenv id funct = + let fv = IdentSet.elements(IdentSet.remove id (free_variables funct)) in + let label = Compilenv.current_unit_name() ^ "_" ^ Ident.unique_name id in + let (params, body) = uncurry_fun funct in + let arity = List.length params in + let env_param = Ident.new "env" in + let cenv_body = + Tbl.add id (Uvar env_param) + (build_closure_env env_param (if arity > 1 then 3 else 2) fv) in + (* Even if fv = [], env may be used inside to refer to the functional + value of the function. Not detected here. *) + {fa_desc = {fun_label = label; fun_arity = arity; fun_closed = false}; + fa_params = params @ [env_param]; + fa_body = body; + fa_cenv = cenv_body; + fa_clos = close_list fenv cenv (List.map (fun id -> Lvar id) fv)} + +(* Actually build the function closure based on infos returned by + [close_analyze_function] *) + +and close_build_function fenv funapp = + (* No need to add [params] to [fenv] since their approximations are + unknown anyway *) + let (ubody, approx) = close fenv funapp.fa_cenv funapp.fa_body in + (Uclosure(funapp.fa_desc.fun_label, funapp.fa_desc.fun_arity, + funapp.fa_params, ubody, funapp.fa_clos), + Value_closure(funapp.fa_desc, approx)) + +(* Close a switch, preserving sharing between cases. *) + +and close_switch fenv cenv num_keys cases = + let index = Array.new num_keys 0 in + let num_cases = ref 0 and ucases = ref [] in + if List.length cases < num_keys then begin + num_cases := 1; + ucases := [Ustaticfail] + end; + List.iter + (function + (key, Lshared(lam, r)) -> + begin match !r with + None -> + let (ulam, _) = close fenv cenv lam in + ucases := ulam :: !ucases; + index.(key) <- !num_cases; + r := Some !num_cases; + incr num_cases + | Some n -> + index.(key) <- n + end + | (key, lam) -> + let (ulam, _) = close fenv cenv lam in + ucases := ulam :: !ucases; + index.(key) <- !num_cases; + incr num_cases) + cases; + List.iter + (function + (key, Lshared(lam, r)) -> r := None + | (key, lam) -> ()) + cases; + (index, Array.of_list(List.rev !ucases)) + +(* The entry point *) + +let intro lam = + let (ulam, approx) = close Tbl.empty Tbl.empty lam in ulam + diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli new file mode 100644 index 000000000..7575cbd4e --- /dev/null +++ b/asmcomp/closure.mli @@ -0,0 +1,4 @@ +(* Introduction of closures, uncurrying, recognition of direct calls *) + +val intro: Lambda.lambda -> Clambda.ulambda + diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 47e39ee7e..a998e0caa 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -1,9 +1,3 @@ -type constant = - Const_int of int - | Const_float of string - | Const_symbol of string - | Const_pointer of int - type machtype_component = Addr | Int @@ -74,7 +68,10 @@ type operation = | Craise type expression = - Cconst of constant + Cconst_int of int + | Cconst_float of string + | Cconst_symbol of string + | Cconst_pointer of int | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -83,7 +80,7 @@ type expression = | Csequence of expression * expression | Cifthenelse of expression * expression * expression | Cswitch of expression * int array * expression array - | Cwhile of expression * expression + | Cloop of expression | Ccatch of expression * expression | Cexit | Ctrywith of expression * Ident.t * expression @@ -91,15 +88,18 @@ type expression = type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; - fun_body: expression } + fun_body: expression; + fun_fast: bool } type data_item = - Clabel of string + Cdefine_symbol of string + | Cdefine_label of int | Cint8 of int | Cint16 of int | Cint of int | Cfloat of string - | Caddress of string + | Csymbol_address of string + | Clabel_address of int | Cstring of string | Cskip of int | Calign of int diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index bcb03b0b4..842d063b9 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -1,11 +1,5 @@ (* Second intermediate language (machine independent) *) -type constant = - Const_int of int - | Const_float of string - | Const_symbol of string - | Const_pointer of int - type machtype_component = Addr | Int @@ -60,7 +54,10 @@ type operation = | Craise type expression = - Cconst of constant + Cconst_int of int + | Cconst_float of string + | Cconst_symbol of string + | Cconst_pointer of int | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -69,7 +66,7 @@ type expression = | Csequence of expression * expression | Cifthenelse of expression * expression * expression | Cswitch of expression * int array * expression array - | Cwhile of expression * expression + | Cloop of expression | Ccatch of expression * expression | Cexit | Ctrywith of expression * Ident.t * expression @@ -77,7 +74,8 @@ type expression = type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; - fun_body: expression } + fun_body: expression; + fun_fast: bool } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml new file mode 100644 index 000000000..d3d159e65 --- /dev/null +++ b/asmcomp/cmmgen.ml @@ -0,0 +1,694 @@ +(* Translation from closed lambda to C-- *) + +open Misc +open Arch +open Asttypes +open Lambda +open Clambda +open Cmm + +(* Block headers *) + +let block_header tag sz = (sz lsl 10) + tag +let closure_header sz = block_header 251 sz +let float_header = block_header 254 (size_float / size_addr) +let string_header len = block_header 253 ((len + size_addr) / size_addr) + +(* Integers *) + +let int_const n = Cconst_int((n lsl 1 + 1)) + +let add_const c n = + if n = 0 then c else Cop(Caddi, [c; Cconst_int n]) + +let incr_int = function + Cop(Caddi, [c; Cconst_int n]) -> add_const c (n+1) + | c -> add_const c 1 + +let decr_int = function + Cop(Caddi, [c; Cconst_int n]) -> add_const c (n-1) + | c -> add_const c (-1) + +let add_int c1 c2 = + match (c1, c2) with + (Cop(Caddi, [c1; Cconst_int n1]), + Cop(Caddi, [c2; Cconst_int n2])) -> + add_const (Cop(Caddi, [c1; c2])) (n1 + n2) + | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> + add_const (Cop(Caddi, [c1; c2])) n1 + | (c1, Cop(Caddi, [c2; Cconst_int n2])) -> + add_const (Cop(Caddi, [c1; c2])) n2 + | (c1, c2) -> + Cop(Caddi, [c1; c2]) + +let sub_int c1 c2 = + match (c1, c2) with + (Cop(Caddi, [c1; Cconst_int n1]), + Cop(Caddi, [c2; Cconst_int n2])) -> + add_const (Cop(Csubi, [c1; c2])) (n1 - n2) + | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> + add_const (Cop(Csubi, [c1; c2])) n1 + | (c1, Cop(Caddi, [c2; Cconst_int n2])) -> + add_const (Cop(Csubi, [c1; c2])) (-n2) + | (c1, Cconst_int n) -> + add_const c1 (-n) + | (c1, c2) -> + Cop(Csubi, [c1; c2]) + +let tag_int = function + Cconst_int n -> Cconst_int((n lsl 1) + 1) + | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) + +let untag_int = function + Cconst_int n -> Cconst_int(n asr 1) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c + | Cop(Clsl, [c; Cconst_int 1]) -> c + | c -> Cop(Casr, [c; Cconst_int 1]) + +(* Bool *) + +let test_bool = function + Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c + | Cop(Clsl, [c; Cconst_int 1]) -> c + | c -> Cop(Ccmpi Cne, [c; Cconst_int 1]) + +(* Float *) + +let box_float c = Cop(Calloc, [Cconst_int float_header; c]) + +let unbox_float = function + Cop(Calloc, [header; c]) -> c + | c -> Cop(Cload typ_float, [c]) + +(* Unit *) + +let return_unit c = Csequence(c, Cconst_int 1) + +let rec remove_unit = function + Csequence(c, Cconst_int 1) -> c + | Csequence(c1, c2) -> + Csequence(c1, remove_unit c2) + | Cifthenelse(cond, ifso, ifnot) -> + Cifthenelse(cond, remove_unit ifso, remove_unit ifnot) + | Cswitch(sel, index, cases) -> + Cswitch(sel, index, Array.map remove_unit cases) + | Ccatch(body, handler) -> + Ccatch(remove_unit body, remove_unit handler) + | Ctrywith(body, exn, handler) -> + Ctrywith(remove_unit body, exn, remove_unit handler) + | c -> c + +(* Access to block fields *) + +let field_address ptr n = + if n = 0 + then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_addr)]) + +let get_field ptr n = + Cop(Cload typ_addr, [field_address ptr n]) + +let set_field ptr n newval = + Cop(Cstore, [field_address ptr n; newval]) + +let tag_offset = + if big_endian then -1 else -size_addr + +let get_tag ptr = + Cop(Cloadchunk Byte_unsigned, + [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) + +(* Determine if a clambda is guaranteed to return an integer or a pointer + outside the heap, making it unneccesary to do Cmodify. *) + +let rec is_outside_heap = function + Uconst _ -> true + | Uprim(p, _) -> + begin match p with + Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint + | Pintcomp _ | Poffsetint _ | Pfloatcomp _ + | Pgetstringchar | Pvectlength -> true + | _ -> false + end + | _ -> false + +(* Array indexing *) + +let log2_size_addr = Misc.log2 size_addr + +let lsl_const c n = + Cop(Clsl, [c; Cconst_int n]) + +let array_indexing ptr ofs = + match ofs with + Cconst_int n -> + field_address ptr (n asr 1) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> + Cop(Cadda, [ptr; lsl_const c log2_size_addr]) + | Cop(Caddi, [c; Cconst_int n]) -> + Cop(Cadda, [ptr; add_const (lsl_const c (log2_size_addr - 1)) + ((n - 1) lsl (log2_size_addr - 1))]) + | _ -> + Cop(Cadda, [ptr; add_const (lsl_const ofs (log2_size_addr - 1)) + ((-1) lsl (log2_size_addr - 1))]) + +(* To compile "let rec" *) + +let rec expr_size = function + Uclosure(lbl, arity, params, body, clos_vars) -> + (if arity = 1 then 2 else 3) + List.length clos_vars + | Uprim(Pmakeblock tag, args) -> + List.length args + | Ulet(id, exp, body) -> + expr_size body + | _ -> + fatal_error "Cmmgen.expr_size" + +let dummy_block size = + if size > 4 then + Cop(Cextcall("alloc_dummy", typ_addr), [Cconst_int size]) + else begin + let rec init_val i = + if i >= size then [] else Cconst_int 0 :: init_val(i+1) in + Cop(Calloc, Cconst_int(block_header 0 size) :: init_val 0) + end + +let rec store_contents ptr = function + Cop(Calloc, fields) -> + Cop(Cstore, field_address ptr (-1) :: fields) + | Clet(id, exp, body) -> + Clet(id, exp, store_contents ptr body) + | _ -> + fatal_error "Cmmgen.store_contents" + +(* Record application and currying functions *) + +let apply_function n = + Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n +let curry_function n = + Compilenv.need_curry_fun n; "caml_curry" ^ string_of_int n + +(* Comparisons *) + +let transl_comparison = function + Lambda.Ceq -> Ceq + | Lambda.Cneq -> Cne + | Lambda.Cge -> Cge + | Lambda.Cgt -> Cgt + | Lambda.Cle -> Cle + | Lambda.Clt -> Clt + +(* Translate structured constants *) + +let const_label = ref 0 + +let new_const_label () = + incr const_label; + !const_label + +let new_const_symbol () = + incr const_label; + Compilenv.current_unit_name () ^ "_" ^ string_of_int !const_label + +let structured_constants = ref ([] : (string * structured_constant) list) + +let transl_constant = function + Const_base(Const_int n) -> + Cconst_int((n lsl 1) + 1) + | Const_base(Const_char c) -> + Cconst_int(((Char.code c) lsl 1) + 1) + | Const_pointer n -> + Cconst_pointer((n lsl 1) + 1) + | cst -> + let lbl = new_const_symbol() in + structured_constants := (lbl, cst) :: !structured_constants; + Cconst_symbol lbl + +(* Local binding of complex expressions *) + +let bind name arg fn = + match arg with + Cvar id -> fn id + | _ -> let id = Ident.new name in Clet(id, arg, fn id) + +(* Translate an expression *) + +let functions = (Queue.new() : (string * Ident.t list * ulambda) Queue.t) + +let rec transl = function + Uvar id -> + Cvar id + | Uconst sc -> + transl_constant sc + | Uclosure(lbl, arity, params, body, clos_vars) -> + Queue.add (lbl, params, body) functions; + if arity = 1 then + Cop(Calloc, + Cconst_int(closure_header(2 + List.length clos_vars)) :: + Cconst_symbol lbl :: + int_const 1 :: + List.map transl clos_vars) + else + Cop(Calloc, + Cconst_int(closure_header(3 + List.length clos_vars)) :: + Cconst_symbol(curry_function arity) :: + int_const arity :: + Cconst_symbol(lbl) :: + List.map transl clos_vars) + | Udirect_apply(lbl, args) -> + Cop(Capply typ_addr, Cconst_symbol lbl :: List.map transl args) + | Ugeneric_apply(clos, [arg]) -> + bind "fun" (transl clos) (fun clos_var -> + Cop(Capply typ_addr, + [get_field (Cvar clos_var) 0; transl arg; Cvar clos_var])) + | Ugeneric_apply(clos, args) -> + let arity = List.length args in + Cop(Capply typ_addr, + Cconst_symbol(apply_function arity) :: + List.map transl (args @ [clos])) + | Ulet(id, exp, body) -> + Clet(id, transl exp, transl body) + | Uletrec(bindings, body) -> + let rec init_blocks = function + [] -> fill_blocks bindings + | (id, exp) :: rem -> + Clet(id, dummy_block(expr_size exp), init_blocks rem) + and fill_blocks = function + [] -> transl body + | (id, exp) :: rem -> + Csequence(store_contents (Cvar id) (transl exp), + fill_blocks rem) + in init_blocks bindings + | Uprim(Pidentity, [arg]) -> + transl arg + | Uprim(Pgetglobal id, []) -> + Cop(Cload typ_addr, [Cconst_symbol(Ident.name id)]) + | Uprim(Psetglobal id, [arg]) -> + Cop(Cstore, [Cconst_symbol(Ident.name id); transl arg]) + | Uprim(Pmakeblock tag, []) -> + transl_constant(Const_block(tag, [])) + | Uprim(Pmakeblock tag, args) -> + Cop(Calloc, Cconst_int(block_header tag (List.length args)) :: + List.map transl args) + | Uprim(Pfield n, [arg]) -> + get_field (transl arg) n + | Uprim(Psetfield n, [loc; newval]) -> + let c = + if is_outside_heap newval then + set_field (transl loc) n (transl newval) + else + bind "modify" (transl loc) (fun loc_var -> + Csequence(Cop(Cmodify, [Cvar loc_var]), + set_field (transl loc) n (transl newval))) + in return_unit c + | Uprim(Pccall(lbl, arity), args) -> + Cop(Cextcall(lbl, typ_addr), List.map transl args) + | Uprim(Praise, [arg]) -> + Cop(Craise, [transl arg]) + | Uprim(Psequand, [arg1; arg2]) -> + Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1) + | Uprim(Psequor, [arg1; arg2]) -> + Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2) + | Uprim(Pnot, [arg]) -> + Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *) + | Uprim(Pnegint, [arg]) -> + Cop(Csubi, [Cconst_int 2; transl arg]) + | Uprim(Paddint, [arg1; arg2]) -> + decr_int(add_int (transl arg1) (transl arg2)) + | Uprim(Psubint, [arg1; arg2]) -> + incr_int(sub_int (transl arg1) (transl arg2)) + | Uprim(Pmulint, [arg1; arg2]) -> + incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) + | Uprim(Pdivint, [arg1; arg2]) -> + tag_int(Cop(Cdivi, [untag_int(transl arg1); untag_int(transl arg2)])) + | Uprim(Pmodint, [arg1; arg2]) -> + tag_int(Cop(Cmodi, [untag_int(transl arg1); untag_int(transl arg2)])) + | Uprim(Pandint, [arg1; arg2]) -> + Cop(Cand, [transl arg1; transl arg2]) + | Uprim(Porint, [arg1; arg2]) -> + Cop(Cor, [transl arg1; transl arg2]) + | Uprim(Pxorint, [arg1; arg2]) -> + incr_int(Cop(Cxor, [transl arg1; transl arg2])) + | Uprim(Plslint, [arg1; arg2]) -> + incr_int(Cop(Clsl, [decr_int(transl arg1); untag_int(transl arg2)])) + | Uprim(Plsrint, [arg1; arg2]) -> + incr_int(Cop(Clsr, [decr_int(transl arg1); untag_int(transl arg2)])) + | Uprim(Pasrint, [arg1; arg2]) -> + incr_int(Cop(Casr, [decr_int(transl arg1); untag_int(transl arg2)])) + | Uprim(Pintcomp cmp, [arg1; arg2]) -> + tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])) + | Uprim(Poffsetint n, [arg]) -> + add_const (transl arg) (n lsl 1) + | Uprim(Poffsetref n, [arg]) -> + return_unit + (bind "ref" (transl arg) (fun arg_var -> + Cop(Cstore, + [Cvar arg_var; + add_const (Cop(Cload typ_int, [Cvar arg_var])) (n lsl 1)]))) + | Uprim(Pnegfloat, [arg]) -> + box_float(Cop(Caddf, [Cconst_float "0.0"; + transl_unbox_float arg])) + | Uprim(Paddfloat, [arg1; arg2]) -> + box_float(Cop(Caddf, [transl_unbox_float arg1; transl_unbox_float arg2])) + | Uprim(Psubfloat, [arg1; arg2]) -> + box_float(Cop(Csubf, [transl_unbox_float arg1; transl_unbox_float arg2])) + | Uprim(Pmulfloat, [arg1; arg2]) -> + box_float(Cop(Cmulf, [transl_unbox_float arg1; transl_unbox_float arg2])) + | Uprim(Pdivfloat, [arg1; arg2]) -> + box_float(Cop(Cdivf, [transl_unbox_float arg1; transl_unbox_float arg2])) + | Uprim(Pfloatcomp cmp, [arg1; arg2]) -> + Cifthenelse(Cop(Ccmpf(transl_comparison cmp), + [transl_unbox_float arg1; transl_unbox_float arg2]), + int_const 1, int_const 0) + | Uprim(Pgetstringchar, [arg1; arg2]) -> + tag_int(Cop(Cloadchunk Byte_unsigned, + [add_int (transl arg1) (untag_int(transl arg2))])) + | Uprim(Psetstringchar, [arg1; arg2; arg3]) -> + return_unit(Cop(Cstorechunk Byte_unsigned, + [add_int (transl arg1) (untag_int(transl arg2)); + transl arg3])) + | Uprim(Pvectlength, [arg]) -> + tag_int(Cop(Clsr, [get_field (transl arg) (-1); Cconst_int 10])) + | Uprim(Pgetvectitem, [arg1; arg2]) -> + Cop(Cload typ_addr, [array_indexing (transl arg1) (transl arg2)]) + | Uprim(Psetvectitem, [arg1; arg2; arg3]) -> + let c = + if is_outside_heap arg3 then + Cop(Cstore, [array_indexing (transl arg1) (transl arg2); + transl arg3]) + else + bind "modify" (transl arg1) (fun loc_var -> + Csequence(Cop(Cmodify, [Cvar loc_var]), + Cop(Cstore, + [array_indexing (Cvar loc_var) (transl arg2); + transl arg3]))) + in return_unit c + | Uprim(Ptranslate tbl, [arg]) -> + bind "transl" (transl arg) (fun arg_id -> + let rec transl_tests lo hi = + if lo > hi then int_const 0 else begin + let i = (lo + hi) / 2 in + let (first_val, last_val, ofs) = tbl.(i) in + Cifthenelse( + Cop(Ccmpi Clt, [Cvar arg_id; int_const first_val]), + transl_tests lo (i-1), + Cifthenelse( + Cop(Ccmpi Cgt, [Cvar arg_id; int_const last_val]), + transl_tests (i+1) hi, + add_const (Cvar arg_id) ((ofs - first_val) * 2))) + end in + transl_tests 0 (Array.length tbl - 1)) + | Uprim(_, _) -> + fatal_error "Cmmgen.transl" + | Uswitch(arg, const_index, const_cases, block_index, block_cases) -> + if Array.length block_index = 0 then + transl_switch (untag_int (transl arg)) const_index const_cases + else if Array.length const_index = 0 then + transl_switch (get_tag (transl arg)) block_index block_cases + else + bind "switch" (transl arg) (fun loc_arg -> + Cifthenelse( + Cop(Cand, [Cvar loc_arg; Cconst_int 1]), + transl_switch (untag_int(Cvar loc_arg)) const_index const_cases, + transl_switch (get_tag(Cvar loc_arg)) block_index block_cases)) + | Ustaticfail -> + Cexit + | Ucatch(body, handler) -> + Ccatch(transl body, transl handler) + | Utrywith(body, exn, handler) -> + Ctrywith(transl body, exn, transl handler) + | Uifthenelse(cond, ifso, ifnot) -> + begin match cond with + Uprim(Pnot, [arg]) -> + transl (Uifthenelse(arg, ifnot, ifso)) + | Uprim(Psequand, _) -> + Ccatch(exit_if_false cond (transl ifso), transl ifnot) + | Uprim(Psequor, _) -> + Ccatch(exit_if_true cond (transl ifnot), transl ifso) + | _ -> + Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot) + end + | Usequence(exp1, exp2) -> + Csequence(remove_unit(transl exp1), transl exp2) + | Uwhile(cond, body) -> + return_unit(Ccatch(Cloop(exit_if_true cond (transl body)), Ctuple [])) + | Ufor(id, low, high, dir, body) -> + let tst = match dir with Upto -> Cgt | Downto -> Clt in + let inc = match dir with Upto -> Caddi | Downto -> Csubi in + return_unit + (Clet(id, transl low, + bind "bound" (transl high) (fun var_high -> + Ccatch( + Cloop(Cifthenelse( + Cop(Ccmpi tst, [Cvar id; Cvar var_high]), + Cexit, + Csequence(remove_unit(transl body), + Cassign(id, Cop(inc, + [Cvar id; Cconst_int 2]))))), + Ctuple [])))) + +and transl_unbox_float = function + Uconst(Const_base(Const_float f)) -> Cconst_float f + | exp -> unbox_float(transl exp) + +and exit_if_true cond otherwise = + match cond with + Uprim(Psequor, [arg1; arg2]) -> + exit_if_true arg1 (exit_if_true arg2 otherwise) + | Uprim(Psequand, [arg1; arg2]) -> + Csequence(Ccatch(exit_if_true arg1 (Ctuple []), + exit_if_true arg2 (Ctuple [])), + otherwise) + | _ -> + Cifthenelse(test_bool(transl cond), Cexit, otherwise) + +and exit_if_false cond otherwise = + match cond with + Uprim(Psequand, [arg1; arg2]) -> + exit_if_false arg1 (exit_if_false arg2 otherwise) + | Uprim(Psequor, [arg1; arg2]) -> + Csequence(Ccatch(exit_if_false arg1 (Ctuple []), + exit_if_false arg2 (Ctuple [])), + otherwise) + | _ -> + Cifthenelse(test_bool(transl cond), otherwise, Cexit) + +and transl_switch arg index cases = + match Array.length index with + 1 -> transl cases.(0) + | 2 -> Cifthenelse(arg, transl cases.(index.(1)), transl cases.(index.(0))) + | _ -> Cswitch(arg, index, Array.map transl cases) + +(* Translate a function definition *) + +let transl_function lbl params body = + Cfunction {fun_name = lbl; + fun_args = List.map (fun id -> (id, typ_addr)) params; + fun_body = transl body; + fun_fast = true} + +(* Translate all function definitions *) + +let rec transl_all_functions cont = + try + let (lbl, params, body) = Queue.take functions in + transl_all_functions(transl_function lbl params body :: cont) + with Queue.Empty -> + cont + +(* Emit structured constants *) + +let rec emit_constant symb cst cont = + match cst with + Const_base(Const_float s) -> + Cint(float_header) :: Cdefine_symbol symb :: Cfloat s :: cont + | Const_base(Const_string s) -> + Cint(string_header (String.length s)) :: + Cdefine_symbol symb :: + emit_string_constant s cont + | Const_block(tag, fields) -> + let (emit_fields, cont1) = emit_constant_fields fields cont in + Cint(block_header tag (List.length fields)) :: + Cdefine_symbol symb :: + emit_fields @ cont1 + | _ -> fatal_error "gencmm.emit_constant" + +and emit_constant_fields fields cont = + match fields with + [] -> ([], cont) + | f1 :: fl -> + let (data1, cont1) = emit_constant_field f1 cont in + let (datal, contl) = emit_constant_fields fl cont1 in + (data1 :: datal, contl) + +and emit_constant_field field cont = + match field with + Const_base(Const_int n) -> + (Cint((n lsl 1) + 1), cont) + | Const_base(Const_char c) -> + (Cint(((Char.code c) lsl 1) + 1), cont) + | Const_base(Const_float s) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(float_header) :: Cdefine_label lbl :: Cfloat s :: cont) + | Const_base(Const_string s) -> + let lbl = new_const_label() in + (Clabel_address lbl, + Cint(string_header (String.length s)) :: Cdefine_label lbl :: + emit_string_constant s cont) + | Const_pointer n -> + (Cint((n lsl 1) + 1), cont) + | Const_block(tag, fields) -> + let lbl = new_const_label() in + let (emit_fields, cont1) = emit_constant_fields fields cont in + (Clabel_address lbl, + Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: + emit_fields @ cont1) + +and emit_string_constant s cont = + let n = size_int - 1 - (String.length s) mod size_int in + Cstring s :: Cskip n :: Cint8 n :: cont + +(* Emit all structured constants *) + +let rec emit_all_constants cont = + match !structured_constants with + [] -> cont + | (lbl, cst) :: rem -> + structured_constants := rem; + emit_all_constants (Cdata(emit_constant lbl cst []) :: cont) + +(* Translate a compilation unit *) + +let compunit ulam = + let glob = Compilenv.current_unit_name () in + Queue.clear functions; + structured_constants := []; + let c1 = [Cfunction {fun_name = glob ^ "_entry"; fun_args = []; + fun_body = transl ulam; fun_fast = false}] in + let c2 = transl_all_functions c1 in + let c3 = emit_all_constants c2 in + Cdata [Cdefine_symbol glob; Cint 0] :: c3 + +(* Generate an application function: + (defun caml_applyN (a1 ... aN clos) + (if (= clos.arity N) + (app clos.direct a1 ... aN clos) + (let (clos1 (app clos.code a1 clos) + clos2 (app clos1.code a2 clos) + ... + closN-1 (app closN-2.code aN-1 closN-2)) + (app closN-1.code aN closN-1)))) +*) + +let apply_function arity = + let arg = Array.new arity (Ident.new "arg") in + for i = 1 to arity - 1 do arg.(i) <- Ident.new "arg" done; + let clos = Ident.new "clos" in + let rec app_fun clos n = + if n = arity-1 then + Cop(Capply typ_addr, + [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]) + else begin + let newclos = Ident.new "clos" in + Clet(newclos, + Cop(Capply typ_addr, + [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), + app_fun newclos (n+1)) + end in + let all_args = Array.to_list arg @ [clos] in + let body = + Cifthenelse( + Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), + Cop(Capply typ_addr, + get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), + app_fun clos 0) in + Cfunction + {fun_name = "caml_apply" ^ string_of_int arity; + fun_args = List.map (fun id -> (id, typ_addr)) all_args; + fun_body = body; + fun_fast = true} + +(* Generate currying functions: + (defun caml_curryN (arg clos) + (alloc HDR caml_curryN_1 arg clos)) + (defun caml_curryN_1 (arg clos) + (alloc HDR caml_curryN_2 arg clos)) + ... + (defun caml_curryN_N-1 (arg clos) + (let (closN-2 clos.cdr + closN-3 closN-2.cdr + ... + clos1 clos2.cdr + clos clos1.cdr) + (app clos.direct + clos1.car clos2.car ... closN-2.car clos.car arg clos))) *) + +let final_curry_function arity = + let last_arg = Ident.new "arg" in + let last_clos = Ident.new "clos" in + let rec curry_fun args clos n = + if n = 0 then + Cop(Capply typ_addr, + get_field (Cvar clos) 2 :: + args @ [Cvar last_arg; Cvar clos]) + else begin + let newclos = Ident.new "clos" in + Clet(newclos, + get_field (Cvar clos) 3, + curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) + end in + Cfunction + {fun_name = "caml_curry" ^ string_of_int arity ^ + "_" ^ string_of_int (arity-1); + fun_args = [last_arg, typ_addr; last_clos, typ_addr]; + fun_body = curry_fun [] last_clos (arity-1); + fun_fast = true} + +let rec intermediate_curry_functions arity num = + if num = arity - 1 then + [final_curry_function arity] + else begin + let name1 = "caml_curry" ^ string_of_int arity in + let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in + let arg = Ident.new "arg" and clos = Ident.new "clos" in + Cfunction + {fun_name = name2; + fun_args = [arg, typ_addr; clos, typ_addr]; + fun_body = Cop(Calloc, + [Cconst_int(closure_header 4); + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); + int_const 1; Cvar arg; Cvar clos]); + fun_fast = true} + :: intermediate_curry_functions arity (num+1) + end + +let curry_function arity = + intermediate_curry_functions arity 0 + +(* Generate the entry point *) + +let entry_point namelist = + let body = + List.fold_right + (fun name next -> + Csequence(Cop(Capply typ_void, [Cconst_symbol(name ^ "_entry")]), + next)) + namelist (Ctuple []) in + Cfunction {fun_name = "caml_program"; + fun_args = []; + fun_body = body; + fun_fast = false} + +(* Generate the table of globals and the master table of frame descriptors *) + +let global_table namelist = + Cdata(Cdefine_symbol "caml_globals" :: + List.map (fun name -> Csymbol_address name) namelist @ + [Cint 0]) + +let frame_table namelist = + Cdata(Cdefine_symbol "caml_frametable" :: + List.map (fun name -> Csymbol_address(name ^ "_frametable")) namelist @ + [Cint 0]) diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli new file mode 100644 index 000000000..a0722ccbe --- /dev/null +++ b/asmcomp/cmmgen.mli @@ -0,0 +1,9 @@ +(* Translation from closed lambda to C-- *) + +val compunit: Clambda.ulambda -> Cmm.phrase list + +val apply_function: int -> Cmm.phrase +val curry_function: int -> Cmm.phrase list +val entry_point: string list -> Cmm.phrase +val global_table: string list -> Cmm.phrase +val frame_table: string list -> Cmm.phrase diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index d75faacc8..b1df303b7 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -2,24 +2,47 @@ open Reg +(* Preallocation of spilled registers in the stack. *) + +let allocate_spilled reg = + if reg.spill then begin + let class = Proc.register_class reg in + let nslots = Proc.num_stack_slots.(class) in + let conflict = Array.new nslots false in + List.iter + (fun r -> + match r.loc with + Stack(Local n) -> + if Proc.register_class r = class then conflict.(n) <- true + | _ -> ()) + reg.interf; + let slot = ref 0 in + while !slot < nslots & conflict.(!slot) do incr slot done; + reg.loc <- Stack(Local !slot); + if !slot >= nslots then Proc.num_stack_slots.(class) <- !slot + 1 + end + (* Compute the degree (= number of neighbours of the same type) of each register, and split them in two sets: unconstrained (degree < number of available registers) - and constrained (degree >= number of available registers) *) + and constrained (degree >= number of available registers). + Spilled registers are ignored in the process. *) let unconstrained = ref Reg.Set.empty let constrained = ref Reg.Set.empty let find_degree reg = - let deg = ref 0 in - let class = Proc.register_class reg in - List.iter - (fun r -> if Proc.register_class r = class then incr deg) - reg.interf; - reg.degree <- !deg; - if !deg >= Proc.num_available_registers.(class) - then constrained := Reg.Set.add reg !constrained - else unconstrained := Reg.Set.add reg !unconstrained + if reg.spill then () else begin + let deg = ref 0 in + let class = Proc.register_class reg in + List.iter + (fun r -> if not r.spill & Proc.register_class r = class then incr deg) + reg.interf; + reg.degree <- !deg; + if !deg >= Proc.num_available_registers.(class) + then constrained := Reg.Set.add reg !constrained + else unconstrained := Reg.Set.add reg !unconstrained + end (* Remove a register from the interference graph *) @@ -223,11 +246,13 @@ let assign_location reg = reg.prefer <- [] let allocate_registers() = - (* First pass: compute the degrees - Second pass: determine coloring order by successive removals of regs - Third pass: assign registers in that order *) + (* First pass: preallocate spill registers + Second pass: compute the degrees + Third pass: determine coloring order by successive removals of regs + Fourth pass: assign registers in that order *) for i = 0 to Proc.num_register_classes - 1 do Proc.num_stack_slots.(i) <- 0 done; + List.iter allocate_spilled (Reg.all_registers()); List.iter find_degree (Reg.all_registers()); List.iter assign_location (remove_all_regs []) diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml new file mode 100644 index 000000000..804601189 --- /dev/null +++ b/asmcomp/compilenv.ml @@ -0,0 +1,136 @@ +(* Compilation environments for compilation units *) + +open Config +open Misc +open Clambda + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string + +exception Error of error + +(* Each .o file has a matching .cmx file that provides the following infos + on the compilation unit: + - list of other units imported, with CRCs of their .cmx files + - approximation of the structure implemented + (includes descriptions of known functions: arity and direct entry + points) + - list of currying functions and application functions needed + The .cmx file contains these infos (as an externed record) plus a CRC + of these infos *) + +type unit_infos = + { mutable ui_name: string; + mutable ui_interfaces: (string * int) list; + mutable ui_imports: (string * int) list; + mutable ui_approx: value_approximation; + mutable ui_curry_fun: int list; + mutable ui_apply_fun: int list } + +let global_approx_table = + (Hashtbl.new 17 : (string, value_approximation) Hashtbl.t) + +let current_unit = + { ui_name = ""; + ui_interfaces = []; + ui_imports = []; + ui_approx = Value_unknown; + ui_curry_fun = []; + ui_apply_fun = [] } + +let reset name crc_intf = + Hashtbl.clear global_approx_table; + current_unit.ui_name <- name; + current_unit.ui_interfaces <- [name, crc_intf]; + current_unit.ui_imports <- []; + current_unit.ui_curry_fun <- []; + current_unit.ui_apply_fun <- [] + +let current_unit_name () = + current_unit.ui_name + +let read_unit_info modname filename = + let ic = open_in_bin filename in + try + let buffer = String.create (String.length cmx_magic_number) in + really_input ic buffer 0 (String.length cmx_magic_number); + if buffer <> cmx_magic_number then begin + close_in ic; + raise(Error(Not_a_unit_info filename)) + end; + let ui = (input_value ic : unit_infos) in + let crc = input_binary_int ic in + close_in ic; + if ui.ui_name <> modname then + raise(Error(Illegal_renaming(modname, filename))); + current_unit.ui_imports <- (modname, crc) :: current_unit.ui_imports; + ui + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_unit_info(filename))) + +(* Return the approximation of a global identifier *) + +let global_approx global_ident = + let modname = Ident.name global_ident in + try + Hashtbl.find global_approx_table modname + with Not_found -> + let approx = + try + let ui = read_unit_info modname + (find_in_path !load_path (lowercase modname ^ ".cmx")) in + ui.ui_approx + with Not_found -> Value_unknown in + Hashtbl.add global_approx_table modname approx; + approx + +(* Register the approximation of the module being compiled *) + +let set_global_approx approx = + current_unit.ui_approx <- approx + +(* Record that a currying function or application function is needed *) + +let need_curry_fun n = + if not (List.mem n current_unit.ui_curry_fun) then + current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun + +let need_apply_fun n = + if not (List.mem n current_unit.ui_apply_fun) then + current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun + +(* Write the description of the current unit *) + +let save_unit_info filename = + current_unit.ui_interfaces <- + current_unit.ui_interfaces @ Env.imported_units(); + let oc = open_out_bin filename in + output_string oc cmx_magic_number; + output_value oc current_unit; + let pos = pos_out oc in + flush oc; + let ic = open_in_bin filename in + let crc = Crc.for_channel ic pos in + close_in ic; + output_binary_int oc crc; + close_out oc + +(* Error report *) + +open Format + +let report_error = function + Not_a_unit_info filename -> + print_string filename; print_space(); + print_string "is not a compilation unit description." + | Corrupted_unit_info filename -> + print_string "Corrupted compilation unit description"; print_space(); + print_string filename + | Illegal_renaming(modname, filename) -> + print_string filename; print_space(); + print_string "contains the description for unit"; print_space(); + print_string modname + diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli new file mode 100644 index 000000000..24b687a41 --- /dev/null +++ b/asmcomp/compilenv.mli @@ -0,0 +1,41 @@ +(* Compilation environments for compilation units *) + +open Clambda + +type unit_infos = + { mutable ui_name: string; (* Name of unit implemented *) + mutable ui_interfaces: (string * int) list; (* Interfaces imported *) + mutable ui_imports: (string * int) list; (* Other units imported *) + mutable ui_approx: value_approximation; (* Approx of the structure *) + mutable ui_curry_fun: int list; (* Currying functions needed *) + mutable ui_apply_fun: int list } (* Apply functions needed *) + +val reset: string -> int -> unit + (* Reset the environment and record the name of the unit being + compiled (first arg) and the CRC of the matching interface + (second arg) *) + +val current_unit_name: unit -> string + (* Return the name of the unit being compiled *) + +val global_approx: Ident.t -> Clambda.value_approximation + (* Return the approximation for the given global identifier *) +val set_global_approx: Clambda.value_approximation -> unit + (* Record the approximation of the unit being compiled *) + +val need_curry_fun: int -> unit +val need_apply_fun: int -> unit + (* Record the need of a currying (resp. application) function + with the given arity *) + +val save_unit_info: string -> unit + (* Save the infos for the current unit in the given file *) + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string + +exception Error of error + +val report_error: error -> unit diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli index 0bf524d23..9bead16b3 100644 --- a/asmcomp/emit.mli +++ b/asmcomp/emit.mli @@ -4,4 +4,3 @@ val fundecl: Linearize.fundecl -> unit val data: Cmm.data_item list -> unit val begin_assembly: unit -> unit val end_assembly: unit -> unit -val fastcode_flag: bool ref diff --git a/asmcomp/emit_alpha.mlp b/asmcomp/emit_alpha.mlp index cc7689bd9..d590e3d9d 100644 --- a/asmcomp/emit_alpha.mlp +++ b/asmcomp/emit_alpha.mlp @@ -75,11 +75,11 @@ let record_frame live = let emit_frame fd = ` .quad {emit_label fd.fd_lbl} + 4\n`; - ` .half {emit_int fd.fd_frame_size}\n`; - ` .half {emit_int (List.length fd.fd_live_offset)}\n`; + ` .word {emit_int fd.fd_frame_size}\n`; + ` .word {emit_int (List.length fd.fd_live_offset)}\n`; List.iter (fun n -> - ` .half {emit_int n}\n`) + ` .word {emit_int n}\n`) fd.fd_live_offset; ` .align 3\n` @@ -89,7 +89,7 @@ let int_reg_number = [| (* 0-8 *) 0; 1; 2; 3; 4; 5; 6; 7; 8; (* 9-12 *) 9; 10; 11; 12; (* 13-18 *) 16; 17; 18; 19; 20; 21; - (* 19-20 *) 22; 23 + (* 19-21 *) 22; 23; 31 |] let float_reg_number = [| @@ -249,19 +249,14 @@ let emit_instr i = | (_, _) -> fatal_error "Emit_alpha: Imove" end - | Lop(Iconstant cst) -> - begin match cst with - Const_int 0 | Const_pointer 0 -> - ` clr {emit_reg i.res.(0)}\n` - | Const_int n -> - ` ldiq {emit_reg i.res.(0)}, {emit_int n}\n` - | Const_float s -> - ` ldit {emit_reg i.res.(0)}, {emit_string s}\n` - | Const_symbol s -> - ` lda {emit_reg i.res.(0)}, {emit_symbol s}\n` - | Const_pointer n -> - ` ldiq {emit_reg i.res.(0)}, {emit_int n}\n` - end + | Lop(Iconst_int 0) -> + ` clr {emit_reg i.res.(0)}\n` + | Lop(Iconst_int n) -> + ` ldiq {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iconst_float s) -> + ` ldit {emit_reg i.res.(0)}, {emit_string s}\n` + | Lop(Iconst_symbol s) -> + ` lda {emit_reg i.res.(0)}, {emit_symbol s}\n` | Lop(Icall_ind) -> ` mov {emit_reg i.arg.(0)}, $27\n`; liveregs i live_27; @@ -271,7 +266,7 @@ let emit_instr i = begin try let entry_point = Hashtbl.find nogp_entry_points s in liveregs i 0; - `{record_frame i.live} bsr {emit_label entry_point}\n` + `{record_frame i.live} bsr {emit_label entry_point} # {emit_symbol s}\n` with Not_found -> ` lda $27, {emit_symbol s}\n`; liveregs i live_27; @@ -458,22 +453,21 @@ let emit_instr i = ` fbeq $f30, {emit_label lbl}\n` end | Lswitch jumptbl -> - (* We're assuming that the first case follows directly the switch - instruction, as linearize does. *) + (* Switches with 1 or 2 cases have normally been eliminated before *) + (* Do something for 3 and 4 cases *) begin match Array.length jumptbl with - 0 -> () (* Should not happen... *) - | 1 -> () (* Should not happen... *) - | 2 -> - ` bne {emit_reg i.arg.(0)}, {emit_label jumptbl.(1)}\n` - | 3 -> + 3 -> + (* Should eliminate the branches that just fall through *) ` subq {emit_reg i.arg.(0)}, 1, $25\n`; + ` blt $25, {emit_label jumptbl.(0)}\n`; ` beq $25, {emit_label jumptbl.(1)}\n`; - ` bgt $25, {emit_label jumptbl.(2)}\n` + ` br {emit_label jumptbl.(2)}\n` | 4 -> + ` beq {emit_reg i.arg.(0)}, {emit_label jumptbl.(0)}\n`; ` subq {emit_reg i.arg.(0)}, 2, $25\n`; + ` blt $25, {emit_label jumptbl.(1)}\n`; ` beq $25, {emit_label jumptbl.(2)}\n`; - ` bgt $25, {emit_label jumptbl.(3)}\n`; - ` bne {emit_reg i.arg.(0)}, {emit_label jumptbl.(1)}\n` + ` br {emit_label jumptbl.(3)}\n` | _ -> let lbl_jumptbl = new_label() in ` lda $25, {emit_label lbl_jumptbl}\n`; @@ -518,6 +512,7 @@ let rec emit_all i = let fundecl fundecl = function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; let noldgp_entry_point = new_label() in tailrec_entry_point := new_label(); stack_offset := 0; @@ -591,10 +586,11 @@ let data l = let begin_assembly() = () -let end_assembly() = +let end_assembly () = + let lbl = Compilenv.current_unit_name() ^ "_frametable" in ` .rdata\n`; - ` .globl Frametable\n`; - `Frametable:\n`; + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; List.iter emit_frame !frame_descriptors; frame_descriptors := []; ` .quad 0\n` diff --git a/asmcomp/emit_i386.mlp b/asmcomp/emit_i386.mlp index 8f17fbc79..198f4a60c 100644 --- a/asmcomp/emit_i386.mlp +++ b/asmcomp/emit_i386.mlp @@ -13,6 +13,11 @@ open Emitaux let fastcode_flag = ref true +(* Symbols are prefixed with _ *) + +let emit_symbol s = + emit_string "_"; Emitaux.emit_symbol s + (* Output a label *) let emit_label lbl = @@ -47,7 +52,7 @@ let emit_shift r = let emit_addressing addr r n = match addr with Ibased(s, d) -> - `_{emit_symbol s}`; + `{emit_symbol s}`; if d <> 0 then ` + {emit_int d}` | Iindexed d -> if d <> 0 then emit_int d; @@ -55,6 +60,9 @@ let emit_addressing addr r n = | Iindexed2 d -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + | Iscaled(scale, d) -> + if d <> 0 then emit_int d; + `(, {emit_reg r.(n)}, {emit_int scale})` | Iindexed2scaled(scale, d) -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` @@ -87,11 +95,11 @@ let record_frame live = let emit_frame fd = ` .long {emit_label fd.fd_lbl} + 4\n`; - ` .half {emit_int fd.fd_frame_size}\n`; - ` .half {emit_int (List.length fd.fd_live_offset)}\n`; + ` .word {emit_int fd.fd_frame_size}\n`; + ` .word {emit_int (List.length fd.fd_live_offset)}\n`; List.iter (fun n -> - ` .half {emit_int n}\n`) + ` .word {emit_int n}\n`) fd.fd_live_offset (* Names for instructions *) @@ -139,37 +147,32 @@ let emit_instr i = ` fstpl {emit_shift i.res.(0)}\n` end end - | Lop(Iconstant cst) -> - begin match cst with - Const_int 0 | Const_pointer 0 -> - begin match i.res.(0).loc with - Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` movl $0, {emit_reg i.res.(0)}\n` - end - | Const_int n -> - ` movl ${emit_int n}, {emit_reg i.res.(0)}\n` - | Const_float f -> - if float_of_string f = 0.0 then - ` fldz\n` - else begin - let lbl = new_label() in - float_constants := (lbl, f) :: !float_constants; - ` fldl {emit_label lbl}\n` - end; - ` fstpl {emit_shift i.res.(0)}\n` - | Const_symbol s -> - ` movl $_{emit_symbol s}, {emit_reg i.res.(0)}\n` - | Const_pointer n -> - ` movl ${emit_int n}, {emit_reg i.res.(0)}\n` + | Lop(Iconst_int 0) -> + begin match i.res.(0).loc with + Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> ` movl $0, {emit_reg i.res.(0)}\n` end + | Lop(Iconst_int n) -> + ` movl ${emit_int n}, {emit_reg i.res.(0)}\n` + | Lop(Iconst_float f) -> + if float_of_string f = 0.0 then + ` fldz\n` + else begin + let lbl = new_label() in + float_constants := (lbl, f) :: !float_constants; + ` fldl {emit_label lbl}\n` + end; + ` fstpl {emit_shift i.res.(0)}\n` + | Lop(Iconst_symbol s) -> + ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> `{record_frame i.live} call *{emit_reg i.arg.(0)}\n` | Lop(Icall_imm s) -> - `{record_frame i.live} call _{emit_symbol s}\n` + `{record_frame i.live} call {emit_symbol s}\n` | Lop(Itailcall_ind) -> let n = frame_size() - 4 in if n > 0 then - ` addl {emit_int n}, %esp\n`; + ` addl ${emit_int n}, %esp\n`; ` jmp *{emit_reg i.arg.(0)}\n` | Lop(Itailcall_imm s) -> if s = !function_name then @@ -177,16 +180,16 @@ let emit_instr i = else begin let n = frame_size() - 4 in if n > 0 then - ` addl {emit_int n}, %esp\n`; - ` jmp _{emit_symbol s}\n` + ` addl ${emit_int n}, %esp\n`; + ` jmp {emit_symbol s}\n` end | Lop(Iextcall s) -> - ` movl $_{emit_symbol s}, %eax\n`; + ` movl ${emit_symbol s}, %eax\n`; `{record_frame i.live} call _caml_c_call\n` | Lop(Istackoffset n) -> if n >= 0 - then ` subl {emit_int n}, %esp\n` - else ` addl {emit_int(-n)}, %esp\n`; + then ` subl ${emit_int n}, %esp\n` + else ` addl ${emit_int(-n)}, %esp\n`; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> begin match i.res.(0).typ with @@ -208,8 +211,12 @@ let emit_instr i = Int | Addr -> ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Float -> - ` fldl {emit_reg i.arg.(0)}\n`; - ` fstpl {emit_addressing addr i.arg 1}\n` + if i.arg.(0).loc = Reg 100 then + ` fstl {emit_addressing addr i.arg 1}\n` + else begin + ` fldl {emit_reg i.arg.(0)}\n`; + ` fstpl {emit_addressing addr i.arg 1}\n` + end end | Lop(Istore(chunk, addr)) -> (* i.arg.(0) is guaranteed to be in %edx *) @@ -223,9 +230,9 @@ let emit_instr i = | Lop(Ialloc n) -> if !fastcode_flag then begin ` movl _young_ptr, %eax\n`; - ` subl ${emit_int n}, $eax\n`; + ` subl ${emit_int n}, %eax\n`; ` movl %eax, _young_ptr\n`; - ` cmpl _young_start, %eax`; + ` cmpl _young_start, %eax\n`; let lbl_cont = new_label() in ` jae {emit_label lbl_cont}\n`; ` movl ${emit_int n}, %eax\n`; @@ -244,9 +251,9 @@ let emit_instr i = | Lop(Imodify) -> (* Argument is in eax *) if !fastcode_flag then begin - ` btsl 10, -4(%eax)\n`; + ` testb $4, -3(%eax)\n`; let lbl_cont = new_label() in - ` jc {emit_label lbl_cont}\n`; + ` jne {emit_label lbl_cont}\n`; ` call _caml_fast_modify\n`; `{emit_label lbl_cont}:\n` end else @@ -324,10 +331,14 @@ let emit_instr i = end; ` addl $8, %esp\n`; stack_offset := !stack_offset + 8 - | Lop(Ispecific Ineg) -> - ` neg {emit_reg i.res.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + ` movl ${emit_int n}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Istore_symbol(s, addr))) -> + ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` | Lreturn -> let n = frame_size() - 4 in if n > 0 then @@ -381,16 +392,15 @@ let emit_instr i = ` je {emit_label lbl}\n` end | Lswitch jumptbl -> + (* Switches with 1 or 2 cases have normally been eliminated before *) + (* Do something for 3 cases *) begin match Array.length jumptbl with - 0 -> () - | 1 -> () - | 2 -> - ` cmpl $0, {emit_reg i.arg.(0)}\n`; - ` jne {emit_label jumptbl.(1)}\n` - | 3 -> + 3 -> + (* Should eliminate the branches that just fall through *) ` cmpl $1, {emit_reg i.arg.(0)}\n`; - ` jg {emit_label jumptbl.(2)}\n`; - ` je {emit_label jumptbl.(1)}\n` + ` jb {emit_label jumptbl.(0)}\n`; + ` je {emit_label jumptbl.(1)}\n`; + ` jmp {emit_label jumptbl.(2)}\n` | n -> let lbl = new_label() in ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`; @@ -430,13 +440,14 @@ let emit_float_constant (lbl, cst) = let fundecl fundecl = function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; ` .text\n`; ` .align 4\n`; - ` .globl _{emit_symbol fundecl.fun_name}\n`; - `_{emit_symbol fundecl.fun_name}:\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; let n = frame_size() - 4 in if n > 0 then ` subl ${emit_int n}, %esp\n`; @@ -448,8 +459,8 @@ let fundecl fundecl = let emit_item = function Cdefine_symbol s -> - ` .globl _{emit_symbol s}\n`; - `_{emit_symbol s}:\n` + ` .globl {emit_symbol s}\n`; + `{emit_symbol s}:\n` | Cdefine_label lbl -> `{emit_label (10000 + lbl)}:\n` | Cint8 n -> @@ -461,7 +472,7 @@ let emit_item = function | Cfloat f -> ` .double {emit_string f}\n` | Csymbol_address s -> - ` .long _{emit_symbol s}\n` + ` .long {emit_symbol s}\n` | Clabel_address lbl -> ` .long {emit_label (10000 + lbl)}\n` | Cstring s -> @@ -491,9 +502,10 @@ let data l = let begin_assembly() = () let end_assembly() = + let lbl = Compilenv.current_unit_name() ^ "_frametable" in ` .data\n`; - ` .globl _Frametable\n`; - `_Frametable:\n`; + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; List.iter emit_frame !frame_descriptors; frame_descriptors := []; ` .long 0\n` diff --git a/asmcomp/emit_sparc.mlp b/asmcomp/emit_sparc.mlp index 5b005ea59..d6f5f1aac 100644 --- a/asmcomp/emit_sparc.mlp +++ b/asmcomp/emit_sparc.mlp @@ -20,6 +20,11 @@ let next_in_pair = function | {loc = Reg r; typ = Float} -> phys_reg (r + 15) | _ -> fatal_error "Emit.next_in_pair" +(* Symbols are prefixed with _ *) + +let emit_symbol s = + emit_string "_"; Emitaux.emit_symbol s + (* Output a label *) let emit_label lbl = @@ -45,11 +50,11 @@ let emit_stack r = let emit_load instr addr arg dst = match addr with Ibased(s, 0) -> - ` sethi %hi(_{emit_symbol s}), %g1\n`; - ` {emit_string instr} [%g1 + %lo(_{emit_symbol s})], {emit_reg dst}\n` + ` sethi %hi({emit_symbol s}), %g1\n`; + ` {emit_string instr} [%g1 + %lo({emit_symbol s})], {emit_reg dst}\n` | Ibased(s, ofs) -> - ` sethi %hi(_{emit_symbol s} + {emit_int ofs}), %g1\n`; - ` {emit_string instr} [%g1 + %lo(_{emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n` + ` sethi %hi({emit_symbol s} + {emit_int ofs}), %g1\n`; + ` {emit_string instr} [%g1 + %lo({emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n` | Iindexed ofs -> if is_immediate ofs then ` {emit_string instr} [{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n` @@ -76,11 +81,11 @@ let emit_load instr addr arg dst = let emit_store instr addr arg src = match addr with Ibased(s, 0) -> - ` sethi %hi(_{emit_symbol s}), %g1\n`; - ` {emit_string instr} {emit_reg src}, [%g1 + %lo(_{emit_symbol s})]\n` + ` sethi %hi({emit_symbol s}), %g1\n`; + ` {emit_string instr} {emit_reg src}, [%g1 + %lo({emit_symbol s})]\n` | Ibased(s, ofs) -> - ` sethi %hi(_{emit_symbol s} + {emit_int ofs}), %g1\n`; - ` {emit_string instr} {emit_reg src}, [%g1 + %lo(_{emit_symbol s} + {emit_int ofs})]\n` + ` sethi %hi({emit_symbol s} + {emit_int ofs}), %g1\n`; + ` {emit_string instr} {emit_reg src}, [%g1 + %lo({emit_symbol s} + {emit_int ofs})]\n` | Iindexed ofs -> if is_immediate ofs then ` {emit_string instr} {emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n` @@ -213,36 +218,26 @@ let emit_instr i = | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconstant cst) -> - begin match cst with - Const_int n -> - if is_immediate n then - ` mov {emit_int n}, {emit_reg i.res.(0)}\n` - else begin - ` sethi %hi({emit_int n}), %g1\n`; - ` or %g1, %lo({emit_int n}), {emit_reg i.res.(0)}\n` - end - | Const_float s -> - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; - ` sethi %hi({emit_label lbl}), %g1\n`; - ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` - | Const_symbol s -> - ` sethi %hi(_{emit_symbol s}), %g1\n`; - ` or %g1, %lo(_{emit_symbol s}), {emit_reg i.res.(0)}\n` - | Const_pointer n -> - if is_immediate n then - ` mov {emit_int n}, {emit_reg i.res.(0)}\n` - else begin - ` sethi %hi({emit_int n}), %g1\n`; - ` or %g1, %lo({emit_int n}), {emit_reg i.res.(0)}\n` - end + | Lop(Iconst_int n) -> + if is_immediate n then + ` mov {emit_int n}, {emit_reg i.res.(0)}\n` + else begin + ` sethi %hi({emit_int n}), %g1\n`; + ` or %g1, %lo({emit_int n}), {emit_reg i.res.(0)}\n` end + | Lop(Iconst_float s) -> + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` sethi %hi({emit_label lbl}), %g1\n`; + ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` + | Lop(Iconst_symbol s) -> + ` sethi %hi({emit_symbol s}), %g1\n`; + ` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> `{record_frame i.live} call {emit_reg i.arg.(0)}\n`; ` nop\n` | Lop(Icall_imm s) -> - `{record_frame i.live} call _{emit_symbol s}\n`; + `{record_frame i.live} call {emit_symbol s}\n`; ` nop\n` | Lop(Itailcall_ind) -> let n = frame_size() in @@ -261,17 +256,17 @@ let emit_instr i = let n = frame_size() in if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; - ` sethi %hi(_{emit_symbol s}), %g1\n`; - ` jmp %g1 + %lo(_{emit_symbol s})\n`; + ` sethi %hi({emit_symbol s}), %g1\n`; + ` jmp %g1 + %lo({emit_symbol s})\n`; if n > 0 then ` add %sp, {emit_int n}, %sp\n` else ` nop\n` end | Lop(Iextcall s) -> - ` sethi %hi(_{emit_symbol s}), %g1\n`; + ` sethi %hi({emit_symbol s}), %g1\n`; `{record_frame i.live} call _caml_c_call\n`; - ` or %g1, %lo(_{emit_symbol s}), %g1\n` + ` or %g1, %lo({emit_symbol s}), %g1\n` | Lop(Istackoffset n) -> ` add %sp, {emit_int (-n)}, %sp\n`; stack_offset := !stack_offset + n @@ -450,34 +445,17 @@ let emit_instr i = ` nop\n` end | Lswitch jumptbl -> - (* We're assuming that the first case follows directly the switch - instruction, as linearize does. *) - begin match Array.length jumptbl with - 0 -> () (* Should not happen... *) - | 1 -> () (* Should not happen... *) - | 2 -> - ` tst {emit_reg i.arg.(0)}\n`; - ` bne {emit_label jumptbl.(1)}\n`; - ` nop\n` - | 3 -> - ` cmp {emit_reg i.arg.(0)}, 1\n`; - ` beq {emit_label jumptbl.(1)}\n`; - ` nop\n`; - ` bg {emit_label jumptbl.(2)}\n`; - ` nop\n` - | _ -> - let lbl_jumptbl = new_label() in - ` sethi %hi({emit_label lbl_jumptbl}), %g1\n`; - ` or %g1, %lo({emit_label lbl_jumptbl}), %g1\n`; - ` sll {emit_reg i.arg.(0)}, 2, %g4\n`; - ` ld [%g1 + %g4], %g1\n`; - ` jmp %g1\n`; - ` nop\n`; - `{emit_label lbl_jumptbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .word {emit_label jumptbl.(i)}\n` - done - end + let lbl_jumptbl = new_label() in + ` sethi %hi({emit_label lbl_jumptbl}), %g1\n`; + ` or %g1, %lo({emit_label lbl_jumptbl}), %g1\n`; + ` sll {emit_reg i.arg.(0)}, 2, %g4\n`; + ` ld [%g1 + %g4], %g1\n`; + ` jmp %g1\n`; + ` nop\n`; + `{emit_label lbl_jumptbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(i)}\n` + done | Lpushtrap lbl -> stack_offset := !stack_offset + 8; ` sub %sp, 8, %sp\n`; @@ -504,13 +482,14 @@ let rec emit_all i = let fundecl fundecl = function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; ` .text\n`; ` .align 4\n`; - ` .global _{emit_symbol fundecl.fun_name}\n`; - `_{emit_symbol fundecl.fun_name}:\n`; + ` .global {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; let n = frame_size() in if n > 0 then ` sub %sp, {emit_int n}, %sp\n`; @@ -524,8 +503,8 @@ let fundecl fundecl = let emit_item = function Cdefine_symbol s -> - ` .global _{emit_symbol s}\n`; - `_{emit_symbol s}:\n` + ` .global {emit_symbol s}\n`; + `{emit_symbol s}:\n` | Cdefine_label lbl -> `{emit_label (lbl + 10000)}:\n` | Cint8 n -> @@ -537,7 +516,7 @@ let emit_item = function | Cfloat f -> ` .double 0r{emit_string f}\n` | Csymbol_address s -> - ` .word _{emit_symbol s}\n` + ` .word {emit_symbol s}\n` | Clabel_address s -> ` .word {emit_label (lbl + 10000)}\n` | Cstring s -> diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index ec93f5e15..2eab8e1bf 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -37,14 +37,15 @@ let build_graph fundecl = let add_interf_set v s = for i = 0 to Array.length v - 1 do let r1 = v.(i) in - Reg.Set.iter (fun r2 -> add_interf r1 r2) s + Reg.Set.iter (add_interf r1) s done in (* Record interferences between elements of an array *) let add_interf_self v = for i = 0 to Array.length v - 2 do + let ri = v.(i) in for j = i+1 to Array.length v - 1 do - add_interf v.(i) v.(j) + add_interf ri v.(j) done done in @@ -55,19 +56,18 @@ let build_graph fundecl = let add_interf_move src dst s = Reg.Set.iter (fun r -> if r.stamp <> src.stamp then add_interf dst r) s in - (* Add a preference between two regs *) + (* Add a preference from one reg to another *) let add_pref weight r1 r2 = if r1.stamp = r2.stamp then () else begin - begin match r1.loc with + match r1.loc with Unknown -> r1.prefer <- (r2, weight) :: r1.prefer | _ -> () - end; - begin match r2.loc with - Unknown -> r2.prefer <- (r1, weight) :: r2.prefer - | _ -> () - end end in + (* Add a mutual preference between two regs *) + let add_mutual_pref weight r1 r2 = + add_pref weight r1 r2; add_pref weight r2 r1 in + (* Update the spill cost of the registers involved in an operation *) let add_spill_cost cost arg = @@ -87,24 +87,18 @@ let build_graph fundecl = | Ireturn -> () | Iop(Imove) -> add_interf_move i.arg.(0) i.res.(0) i.live; - add_pref weight i.arg.(0) i.res.(0); + add_mutual_pref weight i.arg.(0) i.res.(0); interf weight i.next - | Iop(Ispill | Ireload) -> + | Iop(Ispill) -> add_interf_move i.arg.(0) i.res.(0) i.live; - add_pref (weight / 8) i.arg.(0) i.res.(0); + add_pref (weight / 4) i.arg.(0) i.res.(0); + interf weight i.next + | Iop(Ireload) -> + add_interf_move i.arg.(0) i.res.(0) i.live; + add_pref (weight / 4) i.res.(0) i.arg.(0); interf weight i.next | Iop(Itailcall_ind) -> () | Iop(Itailcall_imm lbl) -> () - | Iop(Icall_ind | Icall_imm _) -> - add_interf_set i.res i.live; - add_interf_self i.res; - add_interf_set Proc.destroyed_at_call i.live; - interf weight i.next - | Iop(Iextcall lbl) -> - add_interf_set i.res i.live; - add_interf_self i.res; - add_interf_set Proc.destroyed_at_extcall i.live; - interf weight i.next | Iop op -> add_interf_set i.res i.live; add_interf_self i.res; diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 2f6bfe259..24b42b24d 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -30,7 +30,8 @@ and instruction_desc = type fundecl = { fun_name: string; - fun_body: instruction } + fun_body: instruction; + fun_fast: bool } (* Invert a test *) @@ -137,12 +138,12 @@ let rec linear i n = | Iswitch(index, cases) -> let lbl_cases = Array.new (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in - let n2 = ref n1 in + let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do let (lbl_case, ncase) = get_label(linear cases.(i) (add_branch lbl_end !n2)) in lbl_cases.(i) <- lbl_case; - n2 := ncase + n2 := discard_dead_code ncase done; copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 | Iloop body -> @@ -172,5 +173,6 @@ let rec linear i n = let fundecl f = { fun_name = f.Mach.fun_name; - fun_body = linear f.Mach.fun_body end_instr } + fun_body = linear f.Mach.fun_body end_instr; + fun_fast = f.Mach.fun_fast } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 6d35fc4a1..97e83ac06 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -25,7 +25,8 @@ and instruction_desc = type fundecl = { fun_name: string; - fun_body: instruction } + fun_body: instruction; + fun_fast: bool } val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 96598811b..7260106bb 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -64,7 +64,7 @@ let rec live i finally = let at_join = live i.next finally in let before_handler = live handler at_join in let saved_live_at_raise = !live_at_raise in - live_at_raise := before_handler; + live_at_raise := Reg.Set.remove Proc.loc_exn_bucket before_handler; let before_body = live body at_join in live_at_raise := saved_live_at_raise; i.live <- before_body; diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index ca197c302..9895257d3 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -20,7 +20,9 @@ type operation = Imove | Ispill | Ireload - | Iconstant of Cmm.constant + | Iconst_int of int + | Iconst_float of string + | Iconst_symbol of string | Icall_ind | Icall_imm of string | Itailcall_ind @@ -59,7 +61,8 @@ and instruction_desc = type fundecl = { fun_name: string; fun_args: Reg.t array; - fun_body: instruction } + fun_body: instruction; + fun_fast: bool } let rec dummy_instr = { desc = Iend; @@ -78,6 +81,9 @@ let end_instr () = let instr_cons d a r n = { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } +let instr_cons_live d a r l n = + { desc = d; next = n; arg = a; res = r; live = l } + let rec instr_iter f i = match i.desc with Iend -> () diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index d1e8ddad5..c268f627f 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -20,7 +20,9 @@ type operation = Imove | Ispill | Ireload - | Iconstant of Cmm.constant + | Iconst_int of int + | Iconst_float of string + | Iconst_symbol of string | Icall_ind | Icall_imm of string | Itailcall_ind @@ -59,12 +61,16 @@ and instruction_desc = type fundecl = { fun_name: string; fun_args: Reg.t array; - fun_body: instruction } + fun_body: instruction; + fun_fast: bool } val dummy_instr: instruction val end_instr: unit -> instruction val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction +val instr_cons_live: + instruction_desc -> Reg.t array -> Reg.t array -> Reg.Set.t -> + instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index f224da050..ec406d824 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -3,12 +3,6 @@ open Format open Cmm -let constant = function - Const_int n -> print_int n - | Const_float s -> print_string s - | Const_symbol s -> print_string "\""; print_string s; print_string "\"" - | Const_pointer n -> print_int n; print_string "a" - let machtype_component = function Addr -> print_string "addr" | Int -> print_string "int" @@ -75,7 +69,10 @@ let operation = function | Craise -> print_string "raise" let rec expression = function - Cconst cst -> constant cst + Cconst_int n -> print_int n + | Cconst_float s -> print_string s + | Cconst_symbol s -> print_string "\""; print_string s; print_string "\"" + | Cconst_pointer n -> print_int n; print_string "a" | Cvar id -> Ident.print id | Clet(id, def, (Clet(_, _, _) as body)) -> open_hovbox 2; @@ -102,7 +99,7 @@ let rec expression = function print_string "(let"; print_space(); open_hovbox 2; Ident.print id; print_space(); expression def; - close_box(); + close_box(); print_space(); sequence body; print_string ")"; close_box() | Cassign(id, exp) -> @@ -164,11 +161,10 @@ let rec expression = function close_box() done; close_box() - | Cwhile(e1, e2) -> + | Cloop e -> open_hovbox 2; - print_string "(while"; - print_space(); expression e1; - print_space(); sequence e2; + print_string "(loop"; + print_space(); sequence e; print_string ")"; close_box() | Ccatch(e1, e2) -> open_hovbox 2; @@ -195,8 +191,9 @@ and sequence = function let fundecl f = open_hovbox 1; - print_string "(function "; print_string f.fun_name; print_string " ("; - open_hovbox 0; + print_string "(function "; print_string f.fun_name; print_break(1,4); + open_hovbox 1; + print_string "("; let first = ref true in List.iter (fun (id, ty) -> @@ -204,17 +201,21 @@ let fundecl f = Ident.print id; print_string ": "; machtype ty) f.fun_args; print_string ")"; close_box(); print_space(); + open_hovbox 0; sequence f.fun_body; print_string ")"; - close_box() + close_box(); close_box(); print_newline() let data_item = function - Clabel lbl -> print_string "\""; print_string lbl; print_string "\":" + Cdefine_symbol s -> print_string "\""; print_string s; print_string "\":" + | Cdefine_label l -> print_string "L"; print_int l; print_string ":" | Cint8 n -> print_string "byte "; print_int n | Cint16 n -> print_string "half "; print_int n | Cint n -> print_string "int "; print_int n | Cfloat f -> print_string "float "; print_string f - | Caddress a -> print_string "addr \""; print_string a; print_string "\"" + | Csymbol_address s -> + print_string "addr \""; print_string s; print_string "\"" + | Clabel_address l -> print_string "addr L"; print_int l | Cstring s -> print_string "string \""; print_string s; print_string "\"" | Cskip n -> print_string "skip "; print_int n | Calign n -> print_string "align "; print_int n diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli index 9f530eb43..0d840fd7c 100644 --- a/asmcomp/printcmm.mli +++ b/asmcomp/printcmm.mli @@ -1,6 +1,5 @@ (* Pretty-printing of C-- code *) -val constant : Cmm.constant -> unit val machtype_component : Cmm.machtype_component -> unit val machtype : Cmm.machtype_component array -> unit val comparison : Cmm.comparison -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 80c7664df..ff97b6522 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -76,7 +76,9 @@ let operation op arg res = Imove -> regs arg | Ispill -> regs arg; print_string " (spill)" | Ireload -> regs arg; print_string " (reload)" - | Iconstant cst -> Printcmm.constant cst + | Iconst_int n -> print_int n + | Iconst_float s -> print_string s + | Iconst_symbol s -> print_string "\""; print_string s; print_string "\"" | Icall_ind -> print_string "call "; regs arg | Icall_imm lbl -> print_string "call \""; print_string lbl; @@ -91,12 +93,16 @@ let operation op arg res = | Istackoffset n -> print_string "offset stack "; print_int n | Iload(chunk, addr) -> - print_string "load "; Printcmm.chunk chunk; - Arch.print_addressing reg addr arg + Printcmm.chunk chunk; + print_string "["; + Arch.print_addressing reg addr arg; + print_string "]" | Istore(chunk, addr) -> - print_string "store "; Printcmm.chunk chunk; - reg arg.(Arch.num_args_addressing addr); - print_string " at "; Arch.print_addressing reg addr arg + 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 -> print_string "alloc "; print_int n | Imodify -> print_string "modify "; reg arg.(0) | Iintop(op) -> reg arg.(0); intop op; reg arg.(1) diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 0b9f7f020..71f8305fb 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -9,7 +9,9 @@ val select_addressing: Cmm.expression -> Arch.addressing_mode * Cmm.expression val select_oper: Cmm.operation -> Cmm.expression list -> - Mach.operation * Cmm.expression + Mach.operation * Cmm.expression list +val select_store: + Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression val pseudoregs_for_operation: Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array @@ -31,14 +33,18 @@ val loc_external_arguments: Reg.t array -> Reg.t array * int val loc_external_results: Reg.t array -> Reg.t array val loc_exn_bucket: Reg.t +(* Maximal register pressures for pre-spilling *) + +val safe_register_pressure: int +val max_register_pressure: int array + (* Registers destroyed by operations *) val destroyed_at_oper: Mach.instruction_desc -> Reg.t array -val destroyed_at_call: Reg.t array -val destroyed_at_extcall: Reg.t array val destroyed_at_raise: Reg.t array (* Reloading of instruction arguments, storing of instruction results *) -val reload_test: (Reg.t -> Reg.t) -> Mach.test -> Reg.t array -> Reg.t array +val reload_test: + (Reg.t -> Reg.t) -> Mach.test -> Reg.t array -> Reg.t array val reload_operation: (Reg.t -> Reg.t) -> Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array @@ -49,3 +55,6 @@ val stack_offset: int ref val contains_calls: bool ref val frame_size: unit -> int val slot_offset: Reg.stack_location -> int -> int + +(* Calling the assembler *) +val assemble_file: string -> string -> int diff --git a/asmcomp/proc_alpha.ml b/asmcomp/proc_alpha.ml index 13dc7a02f..6057dbc16 100644 --- a/asmcomp/proc_alpha.ml +++ b/asmcomp/proc_alpha.ml @@ -13,11 +13,11 @@ exception Use_default (* Instruction selection *) let select_addressing = function - Cconst(Const_symbol s) -> + Cconst_symbol s -> (Ibased(s, 0), Ctuple []) - | Cop(Cadda, [Cconst(Const_symbol s); Cconst(Const_int n)]) -> + | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> (Ibased(s, n), Ctuple []) - | Cop(Cadda, [arg; Cconst(Const_int n)]) -> + | Cop(Cadda, [arg; Cconst_int n]) -> (Iindexed n, arg) | arg -> (Iindexed 0, arg) @@ -25,25 +25,27 @@ let select_addressing = function let select_oper op args = match (op, args) with ((Caddi|Cadda), - [arg2; Cop(Clsl, [arg1; Cconst(Const_int(2|3 as shift))])]) -> - (Ispecific(if shift = 2 then Iadd4 else Iadd8), Ctuple[arg1; arg2]) + [arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) -> + (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [arg1; Cconst(Const_int(4|8 as mult))])]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), Ctuple[arg1; arg2]) + [arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [Cconst(Const_int(4|8 as mult)); arg1])]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), Ctuple[arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst(Const_int(2|3 as shift))]); arg2]) -> - (Ispecific(if shift = 2 then Iadd4 else Iadd8), Ctuple[arg1; arg2]) - | (Caddi, [Cop(Cmuli, [arg1; Cconst(Const_int(4|8 as mult))]); arg2]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), Ctuple[arg1; arg2]) - | (Caddi, [Cop(Cmuli, [Cconst(Const_int(4|8 as mult)); arg1]); arg2]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), Ctuple[arg1; arg2]) - | (Csubi, [Cop(Clsl, [arg1; Cconst(Const_int(2|3 as shift))]); arg2]) -> - (Ispecific(if shift = 2 then Isub4 else Isub8), Ctuple[arg1; arg2]) + [arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> + (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) + | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> + (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) + | (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> + (Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2]) | _ -> raise Use_default +let select_store addr exp = raise Use_default + let pseudoregs_for_operation op arg res = raise Use_default let is_immediate (n:int) = true @@ -61,7 +63,7 @@ let is_immediate (n:int) = true $22 - $23 19 - 20 more function arguments $24, $25 temporaries $26-$30 stack ptr, global ptr, etc - $31 always zero + $31 21 always zero $f0 - $f1 100 - 101 function results $f10 - $f15 102 - 107 more function results @@ -75,7 +77,7 @@ let int_reg_name = [| (* 0-8 *) "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; "$8"; (* 9-12 *) "$9"; "$10"; "$11"; "$12"; (* 13-18 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; - (* 19-20 *) "$22"; "$23" + (* 19-21 *) "$22"; "$23"; "$31" |] let float_reg_name = [| @@ -196,15 +198,17 @@ let loc_exn_bucket = phys_reg 0 (* $0 *) (* Registers destroyed by operations *) -let destroyed_at_call = all_phys_regs +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall _) -> all_phys_regs + | _ -> [||] + let destroyed_at_raise = all_phys_regs -let destroyed_at_extcall = (* $9 -$15, $f2 - $f9 preserved *) - Array.of_list(List.map phys_reg - [0; 1; 2; 3; 4; 5; 6; 7; 8; 13; 14; 15; 16; - 17; 18; 19; 20; 100; 101; 102; 103; 104; 105; 106; 107; 116; 117; - 118; 119; 120; 121; 122; 123; 124; 125; 126; 127; 128; 129]) -let destroyed_at_oper op = [||] +(* Maximal register pressure *) + +let max_register_pressure = [| 20; 29 |] + +let safe_register_pressure = 20 (* Reloading *) @@ -232,3 +236,8 @@ let slot_offset loc class = then !stack_offset + n * 8 else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n + +(* Calling the assembler *) + +let assemble_file infile outfile = + Sys.command ("as -O2 -o " ^ outfile ^ " " ^ infile) diff --git a/asmcomp/proc_i386.ml b/asmcomp/proc_i386.ml index 4462af736..933d17998 100644 --- a/asmcomp/proc_i386.ml +++ b/asmcomp/proc_i386.ml @@ -81,23 +81,25 @@ type addressing_expr = let rec select_addr exp = match exp with - Cconst(Const_symbol s) -> + Cconst_symbol s -> (Asymbol s, 0) - | Cop((Caddi | Cadda), [arg; Cconst(Const_int m)]) -> + | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) - | Cop((Caddi | Cadda), [Cconst(Const_int m); arg]) -> + | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n - m) + | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> let (a, n) = select_addr arg in (a, n + m) - | Cop(Clsl, [arg; Cconst(Const_int(1|2|3 as shift))]) -> + | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [arg; Cconst(Const_int(2|4|8 as mult))]) -> + | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end - | Cop(Cmuli, [Cconst(Const_int(2|4|8 as mult)); arg]) -> + | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) @@ -129,7 +131,7 @@ let select_addressing exp = | (Aadd(e1, e2), d) -> (Iindexed2 d, Ctuple[e1; e2]) | (Ascale(e, scale), d) -> - (Iindexed 0, exp) + (Iscaled(scale, d), e) | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) @@ -138,25 +140,42 @@ exception Use_default let select_oper op args = match op with (* Recognize the LEA instruction *) - Caddi | Cadda -> + Caddi | Cadda | Csubi | Csuba -> begin match select_addressing (Cop(op, args)) with - ((Iindexed2 n as addr), arg) when n <> 0 -> - (Ispecific(Ilea addr), arg) - | ((Iindexed2scaled(scale, n) as addr), arg) -> - (Ispecific(Ilea addr), arg) - | _ -> - raise Use_default + (Iindexed d, _) -> raise Use_default + | (Iindexed2 0, _) -> raise Use_default + | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize the NEG instruction *) - | Csubi -> + (* Recognize store instructions *) + | Cstore -> begin match args with - [Cconst(Const_int 0); arg] -> (Ispecific Ineg, arg) - | _ -> raise Use_default + [loc; Cconst_int n] -> + let (addr, arg) = select_addressing loc in + (Ispecific(Istore_int(n, addr)), [arg]) + | [loc; Cconst_pointer n] -> + let (addr, arg) = select_addressing loc in + (Ispecific(Istore_int(n, addr)), [arg]) + | [loc; Cconst_symbol s] -> + let (addr, arg) = select_addressing loc in + (Ispecific(Istore_symbol(s, addr)), [arg]) + | [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] + when loc = loc' -> + let (addr, arg) = select_addressing loc in + (Ispecific(Ioffset_loc(n, addr)), [arg]) + | _ -> + raise Use_default end (* Prevent the recognition of (x / cst) and (x % cst), which do not correspond to an addressing mode. *) - | Cdivi -> (Iintop Idiv, Ctuple args) - | Cmodi -> (Iintop Imod, Ctuple args) + | Cdivi -> (Iintop Idiv, args) + | Cmodi -> (Iintop Imod, args) + | _ -> raise Use_default + +let select_store addr exp = + match exp with + Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple []) | _ -> raise Use_default let pseudoregs_for_operation op arg res = @@ -165,8 +184,7 @@ let pseudoregs_for_operation op arg res = Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) -> ([|res.(0); arg.(1)|], res) (* Two-address unary operations *) - | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) | - Ispecific Ineg -> + | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> (res, res) (* For shifts with variable shift count, second arg must be in ecx *) | Iintop(Ilsl|Ilsr|Iasr) -> @@ -241,7 +259,8 @@ let loc_exn_bucket = phys_reg 0 (* eax *) (* Registers destroyed by operations *) let destroyed_at_oper = function - Iop(Iintop(Idiv | Imod)) -> [| phys_reg 0; phys_reg 3 |] (* eax, edx *) + Iop(Icall_ind | Icall_imm _ | Iextcall _) -> all_phys_regs + | Iop(Iintop(Idiv | Imod)) -> [| phys_reg 0; phys_reg 3 |] (* eax, edx *) | Iop(Ialloc _) -> [| phys_reg 0|] (* eax *) | Iop(Imodify) -> [| phys_reg 0 |] (* eax *) | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| phys_reg 0 |] (* eax *) @@ -249,11 +268,14 @@ let destroyed_at_oper = function | Iifthenelse(Ifloattest _, _, _) -> [| phys_reg 0 |] (* eax *) | _ -> [||] -let destroyed_at_call = all_phys_regs -let destroyed_at_extcall = [| phys_reg 0; phys_reg 2; phys_reg 3 |] - (* eax, ecx, edx *) let destroyed_at_raise = all_phys_regs +(* Maximal register pressure *) + +let max_register_pressure = [|7; 4|] + +let safe_register_pressure = 4 + (* Reloading of instruction arguments, storing of instruction results *) let stackp r = @@ -276,7 +298,7 @@ let reload_operation makereg op arg res = if stackp arg.(0) & stackp arg.(1) then ([|arg.(0); makereg arg.(1)|], res) else (arg, res) - | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ispecific Ineg | + | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat -> (* The argument(s) can be either in register or on stack *) (arg, res) @@ -300,3 +322,8 @@ let slot_offset loc class = then !stack_offset + n * 4 else !stack_offset + num_stack_slots.(0) * 4 + n * 8 | Outgoing n -> n + +(* Calling the assembler *) + +let assemble_file infile outfile = + Sys.command ("as -o " ^ outfile ^ " " ^ infile) diff --git a/asmcomp/proc_sparc.ml b/asmcomp/proc_sparc.ml index 489a3c22e..189085a22 100644 --- a/asmcomp/proc_sparc.ml +++ b/asmcomp/proc_sparc.ml @@ -18,11 +18,11 @@ type addressing_expr = | Aadd of expression * expression let rec select_addr = function - Cconst(Const_symbol s) -> + Cconst_symbol s -> (Asymbol s, 0) - | Cop((Caddi | Cadda), [arg; Cconst(Const_int m)]) -> + | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) - | Cop((Caddi | Cadda), [Cconst(Const_int m); arg]) -> + | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> let (a, n) = select_addr arg in (a, n + m) | Cop((Caddi | Cadda), [arg1; arg2]) -> begin match (select_addr arg1, select_addr arg2) with @@ -47,7 +47,7 @@ let select_addressing exp = let select_oper op args = match (op, args) with - (Cmuli, [arg1; Cconst(Const_int n)]) -> + (Cmuli, [arg1; Cconst_int n]) -> let shift = Misc.log2 n in if n = 1 lsl shift then (Iintop_imm(Ilsl, shift), arg1) diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index 65242da07..649a0b371 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -5,6 +5,7 @@ type t = stamp: int; typ: Cmm.machtype_component; mutable loc: location; + mutable spill: bool; mutable interf: t list; mutable prefer: (t * int) list; mutable degree: int; @@ -24,7 +25,7 @@ and stack_location = type reg = t let dummy = - { name = ""; stamp = 0; typ = Int; loc = Unknown; + { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } let currstamp = ref 0 @@ -32,8 +33,8 @@ let reg_list = ref([] : t list) let new ty = let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; - interf = []; prefer = []; degree = 0; spill_cost = 0; - visited = false } in + spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false } in reg_list := r :: !reg_list; incr currstamp; r @@ -50,7 +51,7 @@ let clone r = nr let at_location ty loc = - let r = { name = ""; stamp = !currstamp; typ = ty; loc = loc; + let r = { name = ""; stamp = !currstamp; typ = ty; loc = loc; spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } in incr currstamp; diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index 550b8b29c..d27d0c09f 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -1,15 +1,16 @@ (* Pseudo-registers *) type t = - { mutable name: string; - stamp: int; - typ: Cmm.machtype_component; - mutable loc: location; - mutable interf: t list; - mutable prefer: (t * int) list; - mutable degree: int; - mutable spill_cost: int; - mutable visited: bool } + { mutable name: string; (* Name (for printing) *) + stamp: int; (* Unique stamp *) + typ: Cmm.machtype_component; (* Type of contents *) + mutable loc: location; (* Actual location *) + mutable spill: bool; (* "true" to force stack allocation *) + mutable interf: t list; (* Other regs live simultaneously *) + mutable prefer: (t * int) list; (* Preferences for other regs *) + mutable degree: int; (* Number of other regs live sim. *) + mutable spill_cost: int; (* Estimate of spilling cost *) + mutable visited: bool } (* For graph walks *) and location = Unknown diff --git a/asmcomp/reload.ml b/asmcomp/reload.ml index 5670d5823..09f91fb55 100644 --- a/asmcomp/reload.ml +++ b/asmcomp/reload.ml @@ -65,7 +65,7 @@ let rec reload i = in hardware registers *) (makeregs i.arg, makeregs i.res) in insert_moves i.arg newarg - (instr_cons i.desc newarg newres + (instr_cons_live i.desc newarg newres i.live (insert_moves newres i.res (reload i.next))) | Iifthenelse(tst, ifso, ifnot) -> @@ -98,6 +98,7 @@ let rec reload i = let fundecl f = redo_regalloc := false; let new_body = reload f.fun_body in - ({fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body}, + ({fun_name = f.fun_name; fun_args = f.fun_args; + fun_body = new_body; fun_fast = f.fun_fast}, !redo_regalloc) diff --git a/asmcomp/selection.ml b/asmcomp/selection.ml index 90cfc993d..70eb0b928 100644 --- a/asmcomp/selection.ml +++ b/asmcomp/selection.ml @@ -1,26 +1,11 @@ -(* Instruction selection and choice of evaluation order. *) +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) open Misc open Cmm +open Reg open Mach -type expression = - Sconst of Cmm.constant - | Svar of Ident.t - | Slet of Ident.t * expression * expression - | Sassign of Ident.t * expression - | Stuple of expression array * int list - | Sop of operation * expression * Cmm.machtype - | Sproj of expression * int * int - | Ssequence of expression * expression - | Sifthenelse of test * expression * expression * expression - | Sswitch of expression * int array * expression array - | Sloop of expression - | Scatch of expression * expression - | Sexit - | Strywith of expression * Ident.t * expression - | Sraise of expression - (* Infer the type of the result of an operation *) let oper_result_type = function @@ -42,43 +27,54 @@ let oper_result_type = function | Craise -> typ_void | _ -> fatal_error "Selection.oper_result_type" -(* Estimate the intrinsic cost of an operation. - The cost reflects both the number of registers destroyed by the operation - and the time it will take to complete. Since subexpressions with higher - cost are evaluated first, this increases slightly the probability that - the result will be ready when needed. *) - -let oper_cost = function - Capply ty -> 32 - | Cextcall(s, ty) -> 16 - | Cload ty -> 2 * Array.length ty - | Cloadchunk c -> 2 - | Cmuli -> 3 - | Cdivi | Cmodi -> 5 - | Caddf | Csubf | Cmulf | Cdivf -> 3 - | _ -> 1 - -(* Common instruction selection for operations *) - -let rec sel_oper op args = +(* Infer the size in bytes of the result of a simple expression *) + +let rec size_expr env = function + Cconst_int _ -> Arch.size_int + | Cconst_symbol _ | Cconst_pointer _ -> Arch.size_addr + | Cconst_float _ -> Arch.size_float + | Cvar v -> + let r = + try + Tbl.find v env + with Not_found -> + fatal_error("Selection.emit_expr: unbound var " ^ Ident.name v) in + size_machtype (Array.map (fun r -> r.typ) r) + | Ctuple el -> + List.fold_right (fun e sz -> size_expr env e + sz) el 0 + | Cop(op, args) -> + size_machtype(oper_result_type op) + | _ -> + fatal_error "Selection.size_expr" + +(* Says if an operation is "safe", i.e. without side-effects *) + +let safe_operation = function + Capply _ | Cextcall(_, _) | Calloc | Cstore | Cstorechunk _ | + Cmodify | Craise -> false + | _ -> true + +(* Default instruction selection for operators *) + +let rec sel_operation op args = match (op, args) with - (Capply ty, Cconst(Const_symbol s) :: rem) -> (Icall_imm s, Ctuple rem) - | (Capply ty, _) -> (Icall_ind, Ctuple args) - | (Cextcall(s, ty), _) -> (Iextcall s, Ctuple args) + (Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem) + | (Capply ty, _) -> (Icall_ind, args) + | (Cextcall(s, ty), _) -> (Iextcall s, args) | (Cload ty, [arg]) -> let (addr, eloc) = Proc.select_addressing arg in - (Iload(Word, addr), eloc) + (Iload(Word, addr), [eloc]) | (Cloadchunk chunk, [arg]) -> let (addr, eloc) = Proc.select_addressing arg in - (Iload(chunk, addr), eloc) + (Iload(chunk, addr), [eloc]) | (Cstore, arg1 :: rem) -> let (addr, eloc) = Proc.select_addressing arg1 in - (Istore(Word, addr), Ctuple(eloc :: rem)) + (Istore(Word, addr), eloc :: rem) | (Cstorechunk chunk, arg1 :: rem) -> let (addr, eloc) = Proc.select_addressing arg1 in - (Istore(chunk, addr), Ctuple(eloc :: rem)) - | (Calloc, _) -> (Ialloc 0, Ctuple args) - | (Cmodify, [arg]) -> (Imodify, arg) + (Istore(chunk, addr), eloc :: rem) + | (Calloc, _) -> (Ialloc 0, args) + | (Cmodify, _) -> (Imodify, args) | (Caddi, _) -> sel_arith_comm Iadd args | (Csubi, _) -> sel_arith Isub args | (Cmuli, _) -> sel_arith_comm Imul args @@ -94,45 +90,45 @@ let rec sel_oper op args = | (Cadda, _) -> sel_arith_comm Iadd args | (Csuba, _) -> sel_arith Isub args | (Ccmpa comp, _) -> sel_arith_comp (Iunsigned comp) args - | (Caddf, _) -> (Iaddf, Ctuple args) - | (Csubf, _) -> (Isubf, Ctuple args) - | (Cmulf, _) -> (Imulf, Ctuple args) - | (Cdivf, _) -> (Idivf, Ctuple args) - | (Cfloatofint, _) -> (Ifloatofint, Ctuple args) - | (Cintoffloat, _) -> (Iintoffloat, Ctuple args) + | (Caddf, _) -> (Iaddf, args) + | (Csubf, _) -> (Isubf, args) + | (Cmulf, _) -> (Imulf, args) + | (Cdivf, _) -> (Idivf, args) + | (Cfloatofint, _) -> (Ifloatofint, args) + | (Cintoffloat, _) -> (Iintoffloat, args) | _ -> fatal_error "Selection.sel_oper" and sel_arith_comm op = function - [arg; Cconst(Const_int n)] when Proc.is_immediate n -> - (Iintop_imm(op, n), arg) - | [arg; Cconst(Const_pointer n)] when Proc.is_immediate n -> - (Iintop_imm(op, n), arg) - | [Cconst(Const_int n); arg] when Proc.is_immediate n -> - (Iintop_imm(op, n), arg) - | [Cconst(Const_pointer n); arg] when Proc.is_immediate n -> - (Iintop_imm(op, n), arg) + [arg; Cconst_int n] when Proc.is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [arg; Cconst_pointer n] when Proc.is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when Proc.is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_pointer n; arg] when Proc.is_immediate n -> + (Iintop_imm(op, n), [arg]) | args -> - (Iintop op, Ctuple args) + (Iintop op, args) and sel_arith op = function - [arg; Cconst(Const_int n)] when Proc.is_immediate n -> - (Iintop_imm(op, n), arg) - | [arg; Cconst(Const_pointer n)] when Proc.is_immediate n -> - (Iintop_imm(op, n), arg) + [arg; Cconst_int n] when Proc.is_immediate n -> + (Iintop_imm(op, n), [arg]) + | [arg; Cconst_pointer n] when Proc.is_immediate n -> + (Iintop_imm(op, n), [arg]) | args -> - (Iintop op, Ctuple args) + (Iintop op, args) and sel_arith_comp cmp = function - [arg; Cconst(Const_int n)] when Proc.is_immediate n -> - (Iintop_imm(Icomp cmp, n), arg) - | [arg; Cconst(Const_pointer n)] when Proc.is_immediate n -> - (Iintop_imm(Icomp cmp, n), arg) - | [Cconst(Const_int n); arg] when Proc.is_immediate n -> - (Iintop_imm(Icomp(swap_intcomp cmp), n), arg) - | [Cconst(Const_pointer n); arg] when Proc.is_immediate n -> - (Iintop_imm(Icomp(swap_intcomp cmp), n), arg) + [arg; Cconst_int n] when Proc.is_immediate n -> + (Iintop_imm(Icomp cmp, n), [arg]) + | [arg; Cconst_pointer n] when Proc.is_immediate n -> + (Iintop_imm(Icomp cmp, n), [arg]) + | [Cconst_int n; arg] when Proc.is_immediate n -> + (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) + | [Cconst_pointer n; arg] when Proc.is_immediate n -> + (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) | args -> - (Iintop(Icomp cmp), Ctuple args) + (Iintop(Icomp cmp), args) and swap_intcomp = function Isigned cmp -> Isigned(swap_comparison cmp) @@ -141,15 +137,15 @@ and swap_intcomp = function (* Instruction selection for conditionals *) let sel_condition = function - Cop(Ccmpi cmp, [arg1; Cconst(Const_int n)]) -> + Cop(Ccmpi cmp, [arg1; Cconst_int n]) -> (Iinttest_imm(Isigned cmp, n), arg1) - | Cop(Ccmpi cmp, [Cconst(Const_int n); arg2]) -> + | Cop(Ccmpi cmp, [Cconst_int n; arg2]) -> (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) | Cop(Ccmpi cmp, args) -> (Iinttest(Isigned cmp), Ctuple args) - | Cop(Ccmpa cmp, [arg1; Cconst(Const_pointer n)]) -> + | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) -> (Iinttest_imm(Iunsigned cmp, n), arg1) - | Cop(Ccmpa cmp, [Cconst(Const_pointer n); arg2]) -> + | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) -> (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) | Cop(Ccmpa cmp, args) -> (Iinttest(Iunsigned cmp), Ctuple args) @@ -158,128 +154,448 @@ let sel_condition = function | arg -> (Itruetest, arg) -(* Flattening of tuples *) +(* Naming of registers *) + +let all_regs_anonymous rv = + try + for i = 0 to Array.length rv - 1 do + if String.length rv.(i).name > 0 then raise Exit + done; + true + with Exit -> + false + +let name_regs id rv = + if Array.length rv = 1 then + rv.(0).name <- Ident.name id + else + for i = 0 to Array.length rv - 1 do + rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i + done + +(* Buffering of instruction sequences *) + +type instruction_sequence = instruction ref + +let new_sequence() = ref dummy_instr + +let insert desc arg res seq = + seq := instr_cons desc arg res !seq -let rec flatten_tuples = function - [] -> [] - | Ctuple el :: rem -> flatten_tuples el @ flatten_tuples rem - | exp :: rem -> exp :: flatten_tuples rem +let extract_sequence seq = + let rec extract res i = + if i == dummy_instr + then res + else extract (instr_cons i.desc i.arg i.res res) i.next in + extract (end_instr()) !seq -(* Enumerate integers *) +(* Insert a sequence of moves from one pseudoreg set to another. *) -let rec interval lo hi = - if lo > hi then [] else lo :: interval (lo+1) hi +let insert_move src dst seq = + if src.stamp <> dst.stamp then + insert (Iop Imove) [|src|] [|dst|] seq -(* Instruction selection and annotation for an expression *) +let insert_moves src dst seq = + for i = 0 to Array.length src - 1 do + insert_move src.(i) dst.(i) seq + done -let rec sel_expr = function - Cconst c -> - (Sconst c, 0) +(* Insert moves and stack offsets for function arguments and results *) + +let insert_move_args arg loc stacksize seq = + if stacksize <> 0 then insert (Iop(Istackoffset stacksize)) [||] [||] seq; + insert_moves arg loc seq + +let insert_move_results loc res stacksize seq = + if stacksize <> 0 then insert(Iop(Istackoffset(-stacksize))) [||] [||] seq; + insert_moves loc res seq + +(* "Join" two instruction sequences, making sure they return their results + in the same registers. *) + +let join r1 seq1 r2 seq2 = + let l1 = Array.length r1 and l2 = Array.length r2 in + if l1 = 0 then r2 + else if l2 = 0 then r1 + else begin + let r = Array.new l1 Reg.dummy in + for i = 0 to l1-1 do + if String.length r1.(i).name = 0 then begin + r.(i) <- r1.(i); + insert_move r2.(i) r1.(i) seq2 + end else if String.length r2.(i).name = 0 then begin + r.(i) <- r2.(i); + insert_move r1.(i) r2.(i) seq1 + end else begin + r.(i) <- Reg.new r1.(i).typ; + insert_move r1.(i) r.(i) seq1; + insert_move r2.(i) r.(i) seq2 + end + done; + r + end + +(* Same, for N branches *) + +let join_array rs = + let dest = ref [||] in + for i = 0 to Array.length rs - 1 do + let (r, s) = rs.(i) in + if Array.length r > 0 then dest := r + done; + if Array.length !dest > 0 then + for i = 0 to Array.length rs - 1 do + let (r, s) = rs.(i) in + if Array.length r > 0 then insert_moves r !dest s + done; + !dest + +(* Add the instructions for the given expression + at the end of the given sequence *) + +let rec emit_expr env exp seq = + match exp with + Cconst_int n -> + let r = Reg.newv typ_int in + insert (Iop(Iconst_int n)) [||] r seq; + r + | Cconst_float n -> + let r = Reg.newv typ_float in + insert (Iop(Iconst_float n)) [||] r seq; + r + | Cconst_symbol n -> + let r = Reg.newv typ_addr in + insert (Iop(Iconst_symbol n)) [||] r seq; + r + | Cconst_pointer n -> + let r = Reg.newv typ_addr in + insert (Iop(Iconst_int n)) [||] r seq; + r | Cvar v -> - (Svar v, 0) + begin try + Tbl.find v env + with Not_found -> + fatal_error("Selection.emit_expr: unbound var " ^ Ident.name v) + end | Clet(v, e1, e2) -> - let (s1, n1) = sel_expr e1 in - let (s2, n2) = sel_expr e2 in - (Slet(v, s1, s2), max n1 (n2 + 1)) + emit_expr (emit_let env v e1 seq) e2 seq | Cassign(v, e1) -> - let (s1, n1) = sel_expr e1 in - (Sassign(v, s1), n1) - | Ctuple(el) -> - begin match flatten_tuples el with - [] -> - (Stuple([||], []), 0) - | [e1] -> - sel_expr e1 - | [e1; e2] -> - let (s1, n1) = sel_expr e1 in - let (s2, n2) = sel_expr e2 in - if n1 >= n2 then - (Stuple([|s1;s2|], [0;1]), max n1 (n2 + 1)) - else - (Stuple([|s1;s2|], [1;0]), max n2 (n1 + 1)) - | el -> - let sv = Array.of_list(List.map sel_expr el) in - let perm = - Sort.list - (fun i j -> - let (_, ni) = sv.(i) and (_, nj) = sv.(j) in i >= j) - (interval 0 (Array.length sv - 1)) in - let need = ref 0 and accu = ref 0 in - List.iter - (fun i -> - let (_, ni) = sv.(i) in - need := max !need (ni + !accu); - incr accu) - perm; - let cases = Array.map (fun (s, n) -> s) sv in - (Stuple(cases, perm), !need) - end + let rv = + try + Tbl.find v env + with Not_found -> + fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in + let r1 = emit_expr env e1 seq in + insert_moves r1 rv seq; + [||] + | Ctuple exp_list -> + let (simple_list, ext_env) = emit_parts_list env exp_list seq in + emit_tuple ext_env simple_list seq + | Cop(Cproj(ofs, len), [Cop(Cload ty, [arg])]) -> + let byte_offset = size_machtype(Array.sub ty 0 ofs) in + emit_expr env + (Cop(Cload(Array.sub ty ofs len), + [Cop(Cadda, [arg; Cconst_int byte_offset])])) seq + | Cop(Cproj(ofs, len), [arg]) -> + let r = emit_expr env arg seq in + Array.sub r ofs len + | Cop(Craise, [arg]) -> + let r1 = emit_expr env arg seq in + let rd = [|Proc.loc_exn_bucket|] in + insert (Iop Imove) r1 rd seq; + insert Iraise rd [||] seq; + [||] + | Cop(op, args) -> + let (simple_args, env) = emit_parts_list env args seq in + let ty = oper_result_type op in + let (new_op, new_args) = + try + Proc.select_oper op simple_args + with Proc.Use_default -> + sel_operation op simple_args in + begin match new_op with + Icall_ind -> + Proc.contains_calls := true; + let r1 = emit_tuple env new_args seq in + let rarg = Array.sub r1 1 (Array.length r1 - 1) in + let rd = Reg.newv ty in + let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in + let loc_res = Proc.loc_results rd in + insert_move_args rarg loc_arg stack_ofs seq; + insert (Iop Icall_ind) (Array.append [|r1.(0)|] loc_arg) loc_res seq; + insert_move_results loc_res rd stack_ofs seq; + rd + | Icall_imm lbl -> + Proc.contains_calls := true; + let r1 = emit_tuple env new_args seq in + let rd = Reg.newv ty in + let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in + let loc_res = Proc.loc_results rd in + insert_move_args r1 loc_arg stack_ofs seq; + insert (Iop(Icall_imm lbl)) loc_arg loc_res seq; + insert_move_results loc_res rd stack_ofs seq; + rd + | Iextcall lbl -> + Proc.contains_calls := true; + let r1 = emit_tuple env new_args seq in + let rd = Reg.newv ty in + let (loc_arg, stack_ofs) = Proc.loc_external_arguments r1 in + let loc_res = Proc.loc_external_results rd in + insert_move_args r1 loc_arg stack_ofs seq; + insert (Iop(Iextcall lbl)) loc_arg loc_res seq; + insert_move_results loc_res rd stack_ofs seq; + rd + | Iload(Word, addr) -> + let r1 = emit_tuple env new_args seq in + let rd = Reg.newv ty in + let a = ref addr in + for i = 0 to Array.length ty - 1 do + insert(Iop(Iload(Word, !a))) r1 [|rd.(i)|] seq; + a := Arch.offset_addressing !a (size_component ty.(i)) + done; + rd + | Istore(Word, addr) -> + begin match new_args with + [] -> fatal_error "Selection.Istore" + | arg_addr :: args_data -> + let ra = emit_expr env arg_addr seq in + emit_stores env args_data seq ra addr; + [||] + end + | Ialloc _ -> + Proc.contains_calls := true; + let rd = Reg.newv typ_addr in + let size = size_expr env (Ctuple new_args) in + insert (Iop(Ialloc size)) [||] rd seq; + emit_stores env new_args seq rd + (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)); + rd + | op -> + if op = Imodify then Proc.contains_calls := true; + let r1 = emit_tuple env new_args seq in + let rd = Reg.newv ty in + begin try + (* Offer the processor description an opportunity to insert moves + before and after the operation, i.e. for two-address + instructions, or instructions using dedicated registers. *) + let (rsrc, rdst) = Proc.pseudoregs_for_operation op r1 rd in + insert_moves r1 rsrc seq; + insert (Iop op) rsrc rdst seq; + insert_moves rdst rd seq + with Proc.Use_default -> + (* Assume no constraints on arg and res registers *) + insert (Iop op) r1 rd seq + end; + rd + end | Csequence(e1, e2) -> - let (s1, n1) = sel_expr e1 in - let (s2, n2) = sel_expr e2 in - (Ssequence(s1, s2), max n1 n2) + emit_expr env e1 seq; + emit_expr env e2 seq | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = sel_condition econd in - let (sarg, narg) = sel_expr earg in - let (sif, nif) = sel_expr eif in - let (selse, nelse) = sel_expr eelse in - (Sifthenelse(cond, sarg, sif, selse), max narg (max nif nelse)) + let rarg = emit_expr env earg seq in + let (rif, sif) = emit_sequence env eif in + let (relse, selse) = emit_sequence env eelse in + let r = join rif sif relse selse in + insert (Iifthenelse(cond, extract_sequence sif, extract_sequence selse)) + rarg [||] seq; + r | Cswitch(esel, index, ecases) -> - let (ssel, nsel) = sel_expr esel in - let scases = Array.map sel_expr ecases in - let need = ref nsel in - for i = 0 to Array.length scases - 1 do - let (_, n) = scases.(i) in need := max !need n - done; - (Sswitch(ssel, index, Array.map (fun (s, n) -> s) scases), !need) - | Cwhile(Cconst(Const_int 1), ebody) -> - let (sbody, nbody) = sel_expr ebody in - (Sloop sbody, nbody) - | Cwhile(econd, ebody) -> - let (cond, earg) = sel_condition econd in - let (sarg, narg) = sel_expr earg in - let (sbody, nbody) = sel_expr ebody in - (Scatch(Sloop(Sifthenelse(cond, sarg, sbody, Sexit)), Stuple([||], [])), - max narg nbody) + let rsel = emit_expr env esel seq in + let rscases = Array.map (emit_sequence env) ecases in + let r = join_array rscases in + insert (Iswitch(index, + Array.map (fun (r, s) -> extract_sequence s) rscases)) + rsel [||] seq; + r + | Cloop(ebody) -> + let (rarg, sbody) = emit_sequence env ebody in + insert (Iloop(extract_sequence sbody)) [||] [||] seq; + [||] | Ccatch(e1, e2) -> - let (s1, n1) = sel_expr e1 in - let (s2, n2) = sel_expr e2 in - (Scatch(s1, s2), max n1 n2) + let (r1, s1) = emit_sequence env e1 in + let (r2, s2) = emit_sequence env e2 in + let r = join r1 s1 r2 s2 in + insert (Icatch(extract_sequence s1, extract_sequence s2)) [||] [||] seq; + r | Cexit -> - (Sexit, 0) + insert Iexit [||] [||] seq; + [||] | Ctrywith(e1, v, e2) -> - let (s1, n1) = sel_expr e1 in - let (s2, n2) = sel_expr e2 in - (Strywith(s1, v, s2), max n1 (n2 + 1)) - | Cop(Cproj(ofs, len), [Cop(Cload ty, [arg])]) -> - sel_expr - (Cop(Cload (Array.sub ty ofs len), - [Cop(Cadda, - [arg; Cconst(Const_int(size_machtype(Array.sub ty 0 ofs)))])])) - | Cop(Cproj(ofs, len), [arg]) -> - let (s, n) = sel_expr arg in (Sproj(s, ofs, len), n) - | Cop(Craise, [arg]) -> - let (s, n) = sel_expr arg in (Sraise s, n) - | Cop(op, args) -> - let ty = oper_result_type op in - let cost = oper_cost op in - (* Offer the processor description a chance to do its own selection, - e.g. to recognize processor-specific instructions *) + let (r1, s1) = emit_sequence env e1 in + let rv = Reg.newv typ_addr in + let (r2, s2) = emit_sequence (Tbl.add v rv env) e2 in + let r = join r1 s1 r2 s2 in + insert + (Itrywith(extract_sequence s1, + instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv + (extract_sequence s2))) + [||] [||] seq; + r + +and emit_sequence env exp = + let seq = new_sequence() in + let r = emit_expr env exp seq in + (r, seq) + +and emit_let env v e1 seq = + let r1 = emit_expr env e1 seq in + if all_regs_anonymous r1 then begin + name_regs v r1; + Tbl.add v r1 env + end else begin + let rv = Array.new (Array.length r1) Reg.dummy in + for i = 0 to Array.length r1 - 1 do rv.(i) <- Reg.new r1.(i).typ done; + name_regs v rv; + insert_moves r1 rv seq; + Tbl.add v rv env + end + +and emit_parts env exp seq = + match exp with + Cconst_int _ | Cconst_float _ | Cconst_symbol _ | Cconst_pointer _ | + Cvar _ -> + (exp, env) + | Ctuple el -> + let (explist, env) = emit_parts_list env el seq in + (Ctuple explist, env) + | Clet(id, arg, body) -> + emit_parts (emit_let env id arg seq) body seq + | Cop(op, args) when safe_operation op -> + let (new_args, new_env) = emit_parts_list env args seq in + (Cop(op, new_args), new_env) + | _ -> + let r = emit_expr env exp seq in + if Array.length r = 0 then + (Ctuple [], env) + else begin + let id = Ident.new "bind" in + (Cvar id, Tbl.add id r env) + end + +and emit_parts_list env exp_list seq = + match exp_list with + [] -> ([], env) + | exp :: rem -> + (* This ensures right-to-left evaluation, consistent with the + bytecode compiler *) + let (new_rem, new_env) = emit_parts_list env rem seq in + let (new_exp, fin_env) = emit_parts new_env exp seq in + (new_exp :: new_rem, fin_env) + +and emit_tuple env exp_list seq = + Array.concat(List.map (fun e -> emit_expr env e seq) exp_list) + +and emit_stores env data seq regs_addr addr = + let a = ref addr in + List.iter + (fun e -> try - let (newop, newarg) = Proc.select_oper op args in - let (sarg, narg) = sel_expr newarg in - (Sop(newop, sarg, ty), narg + cost) + (* Offer the machine description an opportunity to optimize + the store, e.g. if constant -> memory or memory -> memory + moves are available *) + let (op, arg) = Proc.select_store !a e in + let r = emit_expr env arg seq in + insert (Iop op) (Array.append r regs_addr) [||] seq; + a := Arch.offset_addressing !a (size_expr env e) with Proc.Use_default -> - (* Do our own selection *) - match op with - Ccmpf comp -> - let (sarg, narg) = sel_expr (Ctuple args) in - (Sifthenelse(Ifloattest comp, sarg, - Sconst(Const_int 1), Sconst(Const_int 0)), narg) - | _ -> - let (newop, newarg) = sel_oper op args in - let (sarg, narg) = sel_expr newarg in - (Sop(newop, sarg, ty), narg + cost) - -let expression e = - let (s, n) = sel_expr e in s + let r = emit_expr env e seq in + for i = 0 to Array.length r - 1 do + insert (Iop(Istore(Word, !a))) + (Array.append [|r.(i)|] regs_addr) [||] seq; + a := Arch.offset_addressing !a (size_component r.(i).typ) + done) + data + +(* Same, but in tail position *) + +let emit_return env exp seq = + let r = emit_expr env exp seq in + let loc = Proc.loc_results r in + insert_moves r loc seq; + insert Ireturn loc [||] seq + +let rec emit_tail env exp seq = + match exp with + Clet(v, e1, e2) -> + emit_tail (emit_let env v e1 seq) e2 seq + | Cop(Capply ty as op, args) -> + let (simple_args, env) = emit_parts_list env args seq in + let (new_op, new_args) = sel_operation op simple_args in + begin match new_op with + Icall_ind -> + Proc.contains_calls := true; + let r1 = emit_tuple env new_args seq in + let rarg = Array.sub r1 1 (Array.length r1 - 1) in + let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in + if stack_ofs <> 0 then + emit_return env exp seq + else begin + insert_moves rarg loc_arg seq; + insert (Iop Itailcall_ind) + (Array.append [|r1.(0)|] loc_arg) [||] seq + end + | Icall_imm lbl -> + Proc.contains_calls := true; + let r1 = emit_tuple env new_args seq in + let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in + if stack_ofs <> 0 then + emit_return env exp seq + else begin + insert_moves r1 loc_arg seq; + insert (Iop(Itailcall_imm lbl)) loc_arg [||] seq + end + | _ -> fatal_error "Selection.emit_tail" + end + | Cop(Craise, [e1]) -> + let r1 = emit_expr env e1 seq in + let rd = [|Proc.loc_exn_bucket|] in + insert (Iop Imove) r1 rd seq; + insert Iraise rd [||] seq + | Csequence(e1, e2) -> + emit_expr env e1 seq; + emit_tail env e2 seq + | Cifthenelse(econd, eif, eelse) -> + let (cond, earg) = sel_condition econd in + let rarg = emit_expr env earg seq in + insert (Iifthenelse(cond, emit_tail_sequence env eif, + emit_tail_sequence env eelse)) + rarg [||] seq + | Cswitch(esel, index, ecases) -> + let rsel = emit_expr env esel seq in + insert (Iswitch(index, Array.map (emit_tail_sequence env) ecases)) + rsel [||] seq + | Ccatch(e1, e2) -> + insert (Icatch(emit_tail_sequence env e1, emit_tail_sequence env e2)) + [||] [||] seq + | Cexit -> + insert Iexit [||] [||] seq + | _ -> + emit_return env exp seq + +and emit_tail_sequence env exp = + let seq = new_sequence() in + emit_tail env exp seq; + extract_sequence seq + +(* Sequentialization of a function definition *) + +let fundecl f = + Proc.contains_calls := false; + let rargs = + List.map + (fun (id, ty) -> let r = Reg.newv ty in name_regs id r; r) + f.Cmm.fun_args in + let rarg = Array.concat rargs in + let loc_arg = Proc.loc_parameters rarg in + let env = + List.fold_right2 + (fun (id, ty) r env -> Tbl.add id r env) + f.Cmm.fun_args rargs Tbl.empty in + let seq = new_sequence() in + insert_moves loc_arg rarg seq; + emit_tail env f.Cmm.fun_body seq; + { fun_name = f.Cmm.fun_name; + fun_args = loc_arg; + fun_body = extract_sequence seq; + fun_fast = f.Cmm.fun_fast } diff --git a/asmcomp/selection.mli b/asmcomp/selection.mli index 7535b703c..8e8825764 100644 --- a/asmcomp/selection.mli +++ b/asmcomp/selection.mli @@ -1,20 +1,4 @@ -(* Instruction selection and choice of evaluation order. *) +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) -type expression = - Sconst of Cmm.constant - | Svar of Ident.t - | Slet of Ident.t * expression * expression - | Sassign of Ident.t * expression - | Stuple of expression array * int list - | Sop of Mach.operation * expression * Cmm.machtype - | Sproj of expression * int * int - | Ssequence of expression * expression - | Sifthenelse of Mach.test * expression * expression * expression - | Sswitch of expression * int array * expression array - | Sloop of expression - | Scatch of expression * expression - | Sexit - | Strywith of expression * Ident.t * expression - | Sraise of expression - -val expression: Cmm.expression -> expression +val fundecl: Cmm.fundecl -> Mach.fundecl diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index e42bc5a18..4cfdc708d 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -4,12 +4,19 @@ open Reg open Mach -(* We say that a register is "destroyed" if it is live across a high-pressure - point such as a function call or a try...with construct. Actually, not all - physical registers are destroyed at these points, but we'll do as if. +(* We say that a register is "destroyed" if it is live across a construct + that potentially destroys all physical registers: function calls or + try...with constructs. + The "destroyed" registers must therefore reside in the stack during - the high-pressure instructions. We will insert spills (stores) - just after they are defined, and reloads just before they are used. *) + these instructions.. We will insert spills (stores) just after they + are defined, and reloads just before their first use following a + "destroying" construct. + + Instructions with more live registers than actual registers also + "destroy" registers: we mark as "destroyed" the registers live + across the instruction that haven't been used for the longest time. + These registers will be spilled and reloaded as described above. *) (* Association of spill registers to registers *) @@ -20,12 +27,68 @@ let spill_reg r = Reg.Map.find r !spill_env with Not_found -> let spill_r = Reg.new r.typ in + spill_r.spill <- true; if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; spill_env := Reg.Map.add r spill_r !spill_env; spill_r +(* Record the position of last use of registers *) + +let use_date = ref (Reg.Map.empty: int Reg.Map.t) +let current_date = ref 0 + +let record_use regv = + for i = 0 to Array.length regv - 1 do + let r = regv.(i) in + let prev_date = try Reg.Map.find r !use_date with Not_found -> 0 in + if !current_date > prev_date then + use_date := Reg.Map.add r !current_date !use_date + done + +(* Check if the register pressure overflows the maximum pressure allowed + at that point. If so, spill enough registers to lower the pressure. *) + +let add_superpressure_regs live_regs res_regs spilled = + let regs = Reg.add_set_array live_regs res_regs in + (* Compute the pressure in each register class *) + let pressure = Array.new Proc.num_register_classes 0 in + Reg.Set.iter + (fun r -> + if Reg.Set.mem r spilled then () else begin + let c = Proc.register_class r in + pressure.(c) <- pressure.(c) + 1 + end) + regs; + (* Check if pressure is exceeded for each class. *) + let rec check_pressure class spilled = + if class >= Proc.num_register_classes then + spilled + else if pressure.(class) <= Proc.max_register_pressure.(class) then + check_pressure (class+1) spilled + else begin + (* Find the least recently used, unspilled register in the class *) + let lru_date = ref 1000000 and lru_reg = ref Reg.dummy in + Reg.Set.iter + (fun r -> + if Proc.register_class r = class & + not (Reg.Set.mem r spilled) then begin + try + let d = Reg.Map.find r !use_date in + if d < !lru_date then begin + lru_date := d; + lru_reg := r + end + with Not_found -> (* Should not happen *) + () + end) + regs; + pressure.(class) <- pressure.(class) - 1; + check_pressure class (Reg.Set.add !lru_reg spilled) + end in + check_pressure 0 spilled + (* First pass: insert reload instructions based on an approximation of - what's destroyed at pressure points. *) + what is destroyed at pressure points. *) let add_reloads regset i = Reg.Set.fold @@ -36,25 +99,42 @@ let reload_at_exit = ref Reg.Set.empty let reload_at_break = ref Reg.Set.empty let rec reload i before = + incr current_date; + record_use i.arg; + record_use i.res; match i.desc with Iend -> (i, before) | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) - | Iop _ -> + | Iop(Icall_ind | Icall_imm _ | Iextcall _) -> + (* All regs live across must be spilled *) + let (new_next, finally) = reload i.next i.live in + (add_reloads (Reg.inter_set_array before i.arg) + (instr_cons i.desc i.arg i.res new_next), + finally) + | Iop op -> + let new_before = + (* Quick check to see if the register pressure is below the maximum *) + if Reg.Set.cardinal i.live + Array.length i.res <= + Proc.safe_register_pressure + then before + else add_superpressure_regs i.live i.res before in let after = - match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) -> i.live - | _ -> Reg.diff_set_array (Reg.diff_set_array before i.arg) i.res in + Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in let (new_next, finally) = reload i.next after in - (add_reloads (Reg.inter_set_array before i.arg) + (add_reloads (Reg.inter_set_array new_before i.arg) (instr_cons i.desc i.arg i.res new_next), finally) | Iifthenelse(test, ifso, ifnot) -> let at_fork = Reg.diff_set_array before i.arg in + let date_fork = !current_date in let (new_ifso, after_ifso) = reload ifso at_fork in + let date_ifso = !current_date in + current_date := date_fork; let (new_ifnot, after_ifnot) = reload ifnot at_fork in + current_date := max date_ifso !current_date; let (new_next, finally) = reload i.next (Reg.Set.union after_ifso after_ifnot) in (add_reloads (Reg.inter_set_array before i.arg) @@ -63,24 +143,31 @@ let rec reload i before = finally) | Iswitch(index, cases) -> let at_fork = Reg.diff_set_array before i.arg in + let date_fork = !current_date in + let date_join = ref 0 in let after_cases = ref Reg.Set.empty in let new_cases = Array.map (fun c -> + current_date := date_fork; let (new_c, after_c) = reload c at_fork in after_cases := Reg.Set.union !after_cases after_c; + date_join := max !date_join !current_date; new_c) cases in + current_date := !date_join; let (new_next, finally) = reload i.next !after_cases in (add_reloads (Reg.inter_set_array before i.arg) (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next), finally) | Iloop(body) -> + let date_start = !current_date in let at_head = ref before in let final_body = ref body in begin try while true do + current_date := date_start; let (new_body, new_at_head) = reload body !at_head in let merged_at_head = Reg.Set.union !at_head new_at_head in if Reg.Set.equal merged_at_head !at_head then begin @@ -216,12 +303,16 @@ let rec spill i finally = let fundecl f = spill_env := Reg.Map.empty; + use_date := Reg.Map.empty; + current_date := 0; let (body1, _) = reload f.fun_body Reg.Set.empty in let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in let new_body = add_spills (Reg.inter_set_array tospill_at_entry f.fun_args) body2 in spill_env := Reg.Map.empty; + use_date := Reg.Map.empty; { fun_name = f.fun_name; fun_args = f.fun_args; - fun_body = new_body } + fun_body = new_body; + fun_fast = f.fun_fast } diff --git a/asmcomp/split.ml b/asmcomp/split.ml index db797b052..dced8926d 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -3,22 +3,6 @@ open Reg open Mach -(******** -open Format -let print_subst m = - open_hovbox 1; print_string "{"; - let first = ref true in - Reg.Map.iter - (fun r1 r2 -> - if !first then first := false else print_space(); - Printmach.reg r1; print_string "->"; Printmach.reg r2) - m; - print_string "}"; close_box() -let print_subst_opt = function - None -> print_string "None" - | Some s -> print_subst s -**********) - (* Substitutions are represented by register maps *) type subst = Reg.t Reg.Map.t @@ -55,6 +39,7 @@ let repres_regs rv = (* Identify two registers. The second register is chosen as canonical representative. *) + let identify r1 r2 = let repres1 = repres_reg r1 in let repres2 = repres_reg r2 in @@ -83,6 +68,7 @@ let identify_sub sub1 sub2 reg = (* Identify registers so that the two substitutions agree on the registers live before the given instruction. *) + let merge_substs sub1 sub2 i = match (sub1, sub2) with (None, None) -> None @@ -93,6 +79,7 @@ let merge_substs sub1 sub2 i = sub1 (* Same, for N substitutions *) + let merge_subst_array subv instr = let rec find_one_subst i = if i >= Array.length subv then None else begin @@ -199,4 +186,5 @@ let fundecl f = equiv_classes := Reg.Map.empty; { fun_name = f.fun_name; fun_args = new_args; - fun_body = new_body } + fun_body = new_body; + fun_fast = f.fun_fast } |