0005324: Linear Scan Register Allocator for ocamlopt and ocamlnat

Index: driver/main_args.mli =================================================================== --- driver/main_args.mli (Revision 2) +++ driver/main_args.mli (Revision 27) @@ -142,6 +142,8 @@ val _warn_help : unit -> unit val _where : unit -> unit + val _linscan : unit -> unit + val _nopervasives : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit @@ -158,6 +160,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -185,6 +188,8 @@ val _warn_error : string -> unit val _warn_help : unit -> unit + val _linscan : unit -> unit + val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit @@ -200,6 +205,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit Index: driver/main_args.ml =================================================================== --- driver/main_args.ml (Revision 2) +++ driver/main_args.ml (Revision 27) @@ -298,6 +298,11 @@ "-use-prims", Arg.String f, "<file> (undocumented)" ;; +let mk_linscan f = + "-linscan", Arg.Unit f, " (undocumented)" +;; + + let mk_dparsetree f = "-dparsetree", Arg.Unit f, " (undocumented)" ;; @@ -362,6 +367,11 @@ "-dlinear", Arg.Unit f, " (undocumented)" ;; +let mk_dinterval f = + "-dinterval", Arg.Unit f, " (undocumented)" +;; + + let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; @@ -499,6 +509,8 @@ val _warn_help : unit -> unit val _where : unit -> unit + val _linscan : unit -> unit + val _nopervasives : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit @@ -515,6 +527,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -542,6 +555,8 @@ val _warn_error : string -> unit val _warn_help : unit -> unit + val _linscan : unit -> unit + val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit @@ -557,6 +572,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -709,6 +725,8 @@ mk_warn_help F._warn_help; mk_where F._where; + mk_linscan F._linscan; + mk_nopervasives F._nopervasives; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; @@ -718,12 +736,14 @@ mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; @@ -753,6 +773,8 @@ mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk_linscan F._linscan; + mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dcmm F._dcmm; @@ -760,12 +782,14 @@ mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; Index: driver/optmain.ml =================================================================== --- driver/optmain.ml (Revision 2) +++ driver/optmain.ml (Revision 27) @@ -142,6 +142,8 @@ let _warn_help = Warnings.help_warnings let _where () = print_standard_library () + let _linscan = set use_linscan + let _nopervasives = set nopervasives let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda @@ -158,6 +160,7 @@ let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = anonymous Index: asmcomp/interval.mli =================================================================== --- asmcomp/interval.mli (Revision 0) +++ asmcomp/interval.mli (Revision 27) @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + + +open Format + + +type range = + { + mutable rbegin : int; + mutable rend : int; + } + +type interval = + { + mutable reg : Reg.t; + mutable ibegin : int; + mutable iend : int; + mutable ranges : range list; + } + + +val all_intervals : unit -> interval list +val all_fixed_intervals: unit -> interval list +val debug_intervals: formatter -> Mach.fundecl -> unit +val build_intervals: Mach.fundecl -> unit +val live_on: interval -> int -> bool +val overlapping_ranges: range -> range -> bool +val overlapping: interval -> interval -> bool +val strip_expired_ranges: range list -> int -> range list Index: asmcomp/asmgen.ml =================================================================== --- asmcomp/asmgen.ml (Revision 2) +++ asmcomp/asmgen.ml (Revision 27) @@ -20,6 +20,8 @@ open Misc open Cmm +external sys_time : unit -> float = "caml_sys_time" + type error = Assembler_error of string exception Error of error @@ -38,21 +40,53 @@ phrase let rec regalloc ppf round fd = - if round > 50 then - fatal_error(fd.Mach.fun_name ^ - ": function too complex, cannot complete register allocation"); - dump_if ppf dump_live "Liveness analysis" fd; - Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf (); - if !dump_prefer then Printmach.preferences ppf (); - Coloring.allocate_registers(); - dump_if ppf dump_regalloc "After register allocation" fd; - let (newfd, redo_regalloc) = Reload.fundecl fd in - dump_if ppf dump_reload "After insertion of reloading code" newfd; - if redo_regalloc then begin - Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd - end else newfd + if not !use_linscan then begin + if round > 50 then + fatal_error(fd.Mach.fun_name ^ + ": function too complex, cannot complete register allocation"); + dump_if ppf dump_live "Liveness analysis" fd; + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); + Coloring.allocate_registers(); + dump_if ppf dump_regalloc "After register allocation" fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + if redo_regalloc then begin + Reg.reinit(); + Liveness.fundecl ppf newfd; + dump_if ppf dump_reload "After insertion of reloading code" newfd; + regalloc ppf (round + 1) newfd + end + else + begin + dump_if ppf dump_reload "After insertion of reloading code" newfd; + newfd + end + end + else + fd +let rec regalloc_linscan ppf round fd = + if !use_linscan then begin + if round > 50 then + fatal_error(fd.Mach.fun_name ^ + ": function too complex, cannot complete register allocation"); + + Interval.build_intervals fd; + if !dump_interval then Interval.debug_intervals ppf fd; + Linscan.walk_intervals (Interval.all_intervals ()) (Interval.all_fixed_intervals()) fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + dump_if ppf dump_reload "After insertion of reloading code" newfd; + if redo_regalloc then begin + Reg.reinit(); + Liveness.fundecl ppf newfd; + regalloc_linscan ppf (round + 1) newfd + end else newfd + end + else + fd + + let (++) x f = f x let compile_fundecl (ppf : formatter) fd_cmm = @@ -70,7 +104,8 @@ ++ Split.fundecl ++ pass_dump_if ppf dump_split "After live range splitting" ++ liveness ppf - ++ regalloc ppf 1 + ++ regalloc ppf 1 + ++ regalloc_linscan ppf 1 ++ Linearize.fundecl ++ pass_dump_linear_if ppf dump_linear "Linearized code" ++ Scheduling.fundecl Index: asmcomp/interval.ml =================================================================== --- asmcomp/interval.ml (Revision 0) +++ asmcomp/interval.ml (Revision 27) @@ -0,0 +1,290 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + + +open List +open Mach +open Reg + +type range = + { + mutable rbegin : int; + mutable rend : int; + } + +type interval = + { + mutable reg : Reg.t; + mutable ibegin : int; + mutable iend : int; + mutable ranges : range list; + } + + +let interval_list = ref ([] : interval list) +let fixed_interval_list = ref ([] : interval list) +let all_intervals() = !interval_list +let all_fixed_intervals() = !fixed_interval_list + +let overlapping_ranges r0 r1 = + r0.rend > r1.rbegin && r1.rend > r0.rbegin + + +let overlapping i0 i1 = + + let rec test_ranges r0s r1s = + begin match r0s, r1s with + | [], _ -> false + | _, [] -> false + | r0::r0tl, r1::r1tl -> + if overlapping_ranges r0 r1 then true + else if r0.rend < r1.rend then test_ranges r0tl r1s + else if r0.rend > r1.rend then test_ranges r0s r1tl + else test_ranges r0tl r1tl + end + in + + test_ranges i0.ranges i1.ranges + +let live_on i p = + let rec live_on_ranges r = + begin match r with + | [] -> false + | hd::tl -> + if p < hd.rbegin then false + else if p < hd.rend then true + else live_on_ranges tl + end in + live_on_ranges i.ranges + + +let rec strip_expired_ranges ranges pos = + begin match ranges with + | [] -> [] + | hd::tl -> + if hd.rend > pos then ranges + else strip_expired_ranges tl pos + end + + + + +let debug_intervals ppf fd = + Format.fprintf ppf "*** Intervals\n"; + Format.fprintf ppf "%s\n" fd.fun_name; + + let dump_interval i = + Format.fprintf ppf " "; + Printmach.reg ppf i.reg; + List.iter (fun r -> + Format.fprintf ppf " [%d;%d[ " r.rbegin r.rend + ) i.ranges; + Format.fprintf ppf "\n" + in + List.iter dump_interval !fixed_interval_list; + List.iter dump_interval !interval_list; + () + + +let get_and_initialize_interval intervals reg pos_tst pos_set use_kind = + let interval = intervals.(reg.stamp) in + if interval.iend = 0 then begin + interval.ibegin <- pos_tst; + interval.iend <- pos_set; + interval.reg <- reg; + interval.ranges <- [{rbegin = pos_tst; rend = pos_set; }] + end; + interval + + +let update_interval_position intervals pos_tst pos_set use_kind reg = + let interval = get_and_initialize_interval intervals reg pos_tst pos_set use_kind in + let range = begin match interval.ranges with |[] -> Misc.fatal_error "Illegal empty range" | hd::_ -> hd end in + + interval.iend <- pos_set; + + if (range.rend = pos_tst || (range.rend + 1) = pos_tst) && use_kind != 1 then + range.rend <- pos_set + else if range.rbegin = pos_tst && range.rend = pos_tst && use_kind = 1 then + range.rend <- pos_set + else + interval.ranges <- {rbegin=pos_tst;rend=pos_set;} :: interval.ranges + + + +let update_interval_position_by_reg_array intervals regs pos_tst pos_set use_kind = + Array.iter (update_interval_position intervals pos_tst pos_set use_kind) regs + +let update_interval_position_by_reg_set intervals regs pos_tst pos_set use_kind = + Set.iter (update_interval_position intervals pos_tst pos_set use_kind) regs + +let update_interval_position_by_instr intervals instr pos_tst pos_set = + update_interval_position_by_reg_array intervals instr.arg pos_tst pos_set 0; + update_interval_position_by_reg_array intervals instr.res pos_set pos_set 1; + update_interval_position_by_reg_set intervals instr.live pos_tst pos_set 0 + + +let insert_pos_for_live intervals instr pos = + if (not (Set.is_empty instr.live)) || Array.length instr.arg > 0 then + begin + pos := succ !pos; + update_interval_position_by_reg_set intervals instr.live !pos !pos 0; + update_interval_position_by_reg_array intervals instr.arg !pos !pos 0 + end + +let insert_destroyed_at_oper intervals instr pos = + let destroyed = Proc.destroyed_at_oper instr.desc in + if Array.length destroyed > 0 then + update_interval_position_by_reg_array intervals destroyed pos pos 1 + +let insert_destroyed_at_raise intervals pos = + let destroyed = Proc.destroyed_at_raise in + if Array.length destroyed > 0 then + update_interval_position_by_reg_array intervals destroyed pos pos 1 + + +(* generate all intervals. + the intervals will be expanded by one step at the beginning and + the ending of a basic block +*) +let build_intervals fundecl = + + let intervals = Array.init (Reg.num_registers()) (fun i -> + { reg = Reg.dummy; + ibegin = 0; + iend = 0; + ranges = []; + }) in + + + let rec walk_instruction i pos shift = + pos := !pos + 1 + shift; + update_interval_position_by_instr intervals i (!pos - shift) !pos; + + + begin match i.desc with + | Iend -> + (* end ends a bb *) + insert_pos_for_live intervals i pos; + + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true) | Itailcall_ind | Itailcall_imm _) -> + walk_instruction i.next pos 0 + + | Iop _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next pos 0 + + | Ireturn -> + insert_destroyed_at_oper intervals i !pos; + (* returns ends a bb *) + insert_pos_for_live intervals i pos; + walk_instruction i.next pos 0 + + + | Iifthenelse(test, ifso, ifnot) -> + insert_destroyed_at_oper intervals i !pos; + (* if ends a bb *) + insert_pos_for_live intervals i pos; + + (* ifso starts a new bb *) + walk_instruction ifso pos 1; + + (* ifnot starts a new bb *) + walk_instruction ifnot pos 1; + + (* next starts a new bb *) + walk_instruction i.next pos 1 + | Iswitch(index, cases) -> + insert_destroyed_at_oper intervals i !pos; + (* switch ends a bb *) + insert_pos_for_live intervals i pos; + + for j = 0 to Array.length cases -1 do + (* each case starts a new bb *) + walk_instruction cases.(j) pos 1 + done; + (* next starts a new bb *) + walk_instruction i.next pos 1 + | Iloop body -> + insert_destroyed_at_oper intervals i !pos; + (* loop ends a bb *) + insert_pos_for_live intervals i pos; + + (* the body starts a new block *) + walk_instruction body pos 1; + + (* next starts a new bb *) + walk_instruction i.next pos 1 + | Icatch(io, body, handler) -> + insert_destroyed_at_oper intervals i !pos; + (* catch ends a bb *) + insert_pos_for_live intervals i pos; + + (* the body starts a new bb *) + walk_instruction body pos 1; + + (* the handler starts a new bb *) + walk_instruction handler pos 1; + + (* next starts a new bb *) + walk_instruction i.next pos 1; + | Iexit nfail -> + insert_destroyed_at_oper intervals i !pos; + (* exit ends a bb *) + insert_pos_for_live intervals i pos; + + | Itrywith(body, handler) -> + insert_destroyed_at_oper intervals i !pos; + (* trywith ends a bb *) + insert_pos_for_live intervals i pos; + + (* the body starts a new bb *) + walk_instruction body pos 1; + + (* the handler starts a new bb *) + insert_pos_for_live intervals handler pos; + insert_destroyed_at_raise intervals !pos; + walk_instruction handler pos 0; + + (* nex starts a new bb *) + walk_instruction i.next pos 1 + | Iraise -> + (* raise ends a bb *) + insert_pos_for_live intervals i pos; + + walk_instruction i.next pos 1 + end + + + + in + + let pos = ref 0 in + walk_instruction fundecl.fun_body pos 1; + + + interval_list := []; + fixed_interval_list := []; + Array.iter (fun i -> + if i.iend != 0 then begin + i.ranges <- List.rev i.ranges; + begin match i.reg.loc with + | Reg r -> fixed_interval_list := i :: !fixed_interval_list + | _ -> interval_list := i :: !interval_list + end + end) intervals; + + + interval_list := List.sort (fun i0 i1 -> i0.ibegin - i1.ibegin) !interval_list; + + () Index: asmcomp/linscan.ml =================================================================== --- asmcomp/linscan.ml (Revision 0) +++ asmcomp/linscan.ml (Revision 27) @@ -0,0 +1,295 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + +open Interval +open Clflags +open List +open Format +open Mach + + +type active_t = +{ + mutable active : interval list; + mutable inactive : interval list; + mutable fixed : interval list; +} + + +let active = Array.init Proc.num_register_classes (fun i -> {active = []; inactive = []; fixed= [] }) + +let rec insert_into active current = + begin match active with + | [] -> [current] + | interval::tl -> + (* check code for <= or < *) + if interval.iend <= current.iend then + current :: active + else + interval :: insert_into tl current + end + + +let rec release_expired_fixed pos intervals = + begin match intervals with + | [] -> [] + | interval::tl -> + if interval.iend > pos then begin + interval.ranges <- Interval.strip_expired_ranges interval.ranges pos; + interval :: release_expired_fixed pos tl + end + else + [] + end + + +let rec release_expired_active active_cl pos intervals = + begin match intervals with + | [] -> [] + | interval::tl -> + if interval.iend > pos then begin + interval.ranges <- Interval.strip_expired_ranges interval.ranges pos; + if Interval.live_on interval pos then + interval :: release_expired_active active_cl pos tl + else begin + active_cl.inactive <- insert_into active_cl.inactive interval; + release_expired_active active_cl pos tl + end + end + else + [] + end + +let rec release_expired_inactive active_cl pos intervals = + begin match intervals with + | [] -> [] + | interval::tl -> + if interval.iend > pos then begin + interval.ranges <- Interval.strip_expired_ranges interval.ranges pos; + if not (Interval.live_on interval pos) then + interval :: release_expired_inactive active_cl pos tl + else begin + active_cl.active <- insert_into active_cl.active interval; + release_expired_inactive active_cl pos tl + end + end + else + [] + end + + + + +let get_stack_slot cl = + let nslots = Proc.num_stack_slots.(cl) in + Proc.num_stack_slots.(cl) <- nslots + 1; + nslots + + + +let pop_active active = + begin match active with + | [] -> [] + | _::tl -> tl + end + + +(* find a register for the given interval and assigns this + register. The interval is inserted into active. + If there is no space available for this interval then + nothings happens and false is returned. Otherwise + returns true. + *) +let try_alloc_free_register interval = + let cl = Proc.register_class interval.reg in + (* this intervals has already been spilled *) + if interval.reg.Reg.spill then begin + begin match interval.reg.Reg.loc with + | Reg.Unknown -> interval.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + | _ -> () + end + end; + + let num = Proc.num_available_registers.(cl) in + if interval.reg.Reg.loc != Reg.Unknown then true (* this register is already allocated or spilled *) + else if num = 0 then false (* there are not registers for this class *) + else begin + let first_reg = Proc.first_available_register.(cl) in + let active_cl = active.(cl) in + + (* create array containing all possible free regs *) + let regs = Array.make num true in + + (* remove all assigned registers from the free array *) + let rec remove_bound actives = + begin match actives with + | [] -> () + | i::tl -> + begin + begin match i.reg.Reg.loc with + | Reg.Reg(r) -> regs.(r - first_reg) <- false + | _ -> () + end; + remove_bound tl + end + end + in + + remove_bound active_cl.active; + + (* remove all overlapping registers from the free array *) + let rec remove_bound_overlapping fix = + begin match fix with + | [] -> () + | i::tl -> + begin + begin match i.reg.Reg.loc with + | Reg.Reg(r) -> + if regs.(r-first_reg) && Interval.overlapping i interval then + regs.(r - first_reg) <- false + | _ -> () + end; + remove_bound_overlapping tl + end + end + in + remove_bound_overlapping active_cl.inactive; + remove_bound_overlapping active_cl.fixed; + + + let rec find_first_free_reg c = + if c = num then -1 + else if regs.(c) then c + else find_first_free_reg (c+1) in + + let first_free_reg = find_first_free_reg 0 in + + if first_free_reg = -1 then false + else begin + (* assign the free register *) + interval.reg.Reg.loc <- Reg.Reg (first_reg + first_free_reg); + interval.reg.Reg.spill <- false; + (* and insert the current interval into active *) + active_cl.active <- insert_into active_cl.active interval; + true + end; + end + + +let allocate_blocked_register interval = + let cl = Proc.register_class interval.reg in + let active_cl = active.(cl) in + + + if active_cl.active = [] then begin + (* this is the special case when there are no register at all + in the register class. This can happen e.g. for float Regs on i386 *) + interval.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + interval.reg.Reg.spill <- true + end + else begin + + (* get the latest interval in active *) + let last_active = List.hd active_cl.active in + + if last_active.iend > interval.iend then begin + (* last interval in active ends latest -> spill it*) + + (* transfer the register from the active in the current interval *) + begin match last_active.reg.Reg.loc with + | Reg.Reg r -> interval.reg.Reg.loc <- Reg.Reg r + | _ -> () + end; + + (* remove the latest interval from active ... *) + active_cl.active <- pop_active active_cl.active; + (* ... and insert the current *) + active_cl.active <- insert_into active_cl.active interval; + + (* now get a new stack slot for the spilled register *) + last_active.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + last_active.reg.Reg.spill <- true + end + else begin + (* the current interval ends latest -> spill it *) + interval.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + interval.reg.Reg.spill <- true + end; + end; + () + + +let handle_interval interval = + let position = interval.ibegin in + + (* release all intervals that have been expired at the current step*) + for i = 0 to Proc.num_register_classes - 1 do + let active_cl = active.(i) in + active_cl.active <- release_expired_active active_cl position active_cl.active; + active_cl.inactive <- release_expired_inactive active_cl position active_cl.inactive; + active_cl.fixed <- release_expired_fixed position active_cl.fixed; + done; + + + (* find a register for allocation *) + if not (try_alloc_free_register interval) then + (* a valid free register could not be found, so we have to + decide which interval is to be spilled *) + allocate_blocked_register interval + +(* create active liste for every register class *) +let initialize_interval_lists intervals = + + + for i=0 to Proc.num_register_classes - 1 do + let active_cl = active.(i) in + (* start with empty actives *) + active_cl.active <- []; + active_cl.inactive <- []; + active_cl.fixed <- []; + done; + + (* add all fixed intervals to the list of active_fixed intervals *) + let rec add_fixed_intervals intervals = + begin match intervals with + | [] -> () + | i :: tl -> + let active_cl = active.(Proc.register_class i.reg) in + active_cl.fixed <- i :: active_cl.fixed; + add_fixed_intervals tl + end in + add_fixed_intervals intervals; + + for i = 0 to Proc.num_register_classes - 1 do + let active_cl = active.(i) in + active_cl.fixed <- List.sort (fun i0 i1 -> i1.iend - i0.iend) active_cl.fixed + done + + + + + +let walk_intervals intervals fixed_intervals fd = + (* Initialize the stack slots *) + for i = 0 to Proc.num_register_classes - 1 do + Proc.num_stack_slots.(i) <- 0 + done; + + + (* create the active lists *) + initialize_interval_lists fixed_intervals; + + + (* Walk all the intervals within the list *) + List.iter handle_interval intervals + Index: asmcomp/linscan.mli =================================================================== --- asmcomp/linscan.mli (Revision 0) +++ asmcomp/linscan.mli (Revision 27) @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + + +val walk_intervals: Interval.interval list -> Interval.interval list -> Mach.fundecl -> unit + Index: Makefile =================================================================== --- Makefile (Revision 2) +++ Makefile (Revision 27) @@ -79,6 +79,7 @@ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo Index: toplevel/opttopmain.ml =================================================================== --- toplevel/opttopmain.ml (Revision 2) +++ toplevel/opttopmain.ml (Revision 27) @@ -85,6 +85,8 @@ let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings + let _linscan = set use_linscan + let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda @@ -100,6 +102,7 @@ let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = file_argument Index: Makefile.nt =================================================================== --- Makefile.nt (Revision 2) +++ Makefile.nt (Revision 27) @@ -76,6 +76,7 @@ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo Index: utils/clflags.ml =================================================================== --- utils/clflags.ml (Revision 2) +++ utils/clflags.ml (Revision 27) @@ -26,6 +26,7 @@ and make_archive = ref false (* -a *) and debug = ref false (* -g *) and fast = ref false (* -unsafe *) +and use_linscan = ref false (* -linscan *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) @@ -73,6 +74,7 @@ let dump_reload = ref false (* -dreload *) let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) +let dump_interval = ref false (* -dinterval *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) Index: utils/clflags.mli =================================================================== --- utils/clflags.mli (Revision 2) +++ utils/clflags.mli (Revision 27) @@ -23,6 +23,7 @@ val make_archive : bool ref val debug : bool ref val fast : bool ref +val use_linscan : bool ref val link_everything : bool ref val custom_runtime : bool ref val output_c_object : bool ref @@ -67,6 +68,7 @@ val dump_reload : bool ref val dump_scheduling : bool ref val dump_linear : bool ref +val dump_interval : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref

command opt_gc opt_ls opt_gc/ls ------------------------------------------------------------------------------------------------------------------------------------- binarytree 11 0.034 0.034 1.000 binarytree 16 1.193 1.190 1.003 binarytree 20 33.120 33.457 0.990 fasta 100 0.250 0.251 0.996 fasta 250000 0.294 0.294 1.000 fasta 25000000 3.322 3.325 0.999 fasta0 100 0.000 0.000 nan fasta0 250000 0.304 0.304 1.000 fasta0 25000000 3.309 3.319 0.997 fasta2 100 0.274 0.273 1.004 fasta2 250000 0.304 0.304 1.000 fasta2 25000000 3.313 3.325 0.996 mandelbrot 1000 0.124 0.128 0.969 mandelbrot 4000 1.978 2.033 0.973 mandelbrot 16000 31.674 32.438 0.976 mandelbrot1 1000 0.165 0.165 1.000 mandelbrot1 4000 2.619 2.618 1.000 mandelbrot1 16000 41.841 41.700 1.003 mandelbrot2 1000 0.141 0.143 0.986 mandelbrot2 4000 2.243 2.271 0.988 mandelbrot2 16000 35.828 36.171 0.991 mandelbrot3 1000 0.000 0.000 nan mandelbrot3 4000 2.251 2.247 1.002 mandelbrot3 16000 35.899 35.867 1.001 mandelbrot4 1000 0.147 0.153 0.961 mandelbrot4 4000 2.563 2.641 0.970 mandelbrot4 16000 42.253 43.690 0.967 mandelbrot5 1000 0.232 0.245 0.947 mandelbrot5 4000 3.653 3.838 0.952 mandelbrot5 16000 60.526 63.426 0.954 meteor 2098 0.591 0.598 0.988 nbody 500000 0.088 0.092 0.957 nbody 3000000 0.528 0.553 0.955 nbody 5500000 0.968 1.015 0.954 spectral 500 0.060 0.063 0.952 spectral 3000 4.496 4.746 0.947 spectral 5500 16.602 17.191 0.966 almabench 1.910 1.939 0.985 almabench.unsafe 1.822 1.871 0.974 bdd 0.379 0.387 0.979 boyer 0.490 0.490 1.000 fft 0.244 0.245 0.996 nucleic 0.369 0.379 0.974 quicksort 0.151 0.150 1.007 quicksort.unsafe 0.124 0.125 0.992 soli 0.005 0.005 1.000 soli.unsafe 0.004 0.003 1.333 sorts 2.373 2.384 0.995 Testumgebung: ------------- MacBook Pro 13" (Early 2011) 2.7 GHz Intel Core i7 2 GB 1333 MHz DDR3 Mac OS X Lion 10.7 (11A511) OCaml 3.12.1 (linscan) gcc version 4.2.1 (Based on Apple Inc. build 5658) (LLVM build 2335.15.00)

command opt_gc opt_ls opt_gc/ls ------------------------------------------------------------------------------------------------------------------------------------- binarytree 11 0.072 0.072 1.000 binarytree 16 2.796 2.780 1.006 binarytree 20 74.224 73.688 1.007 fasta 100 0.024 0.024 1.000 fasta 250000 0.404 0.408 0.990 fasta 25000000 33.350 33.402 0.998 fasta0 100 0.000 0.000 -nan fasta0 250000 0.404 0.408 0.990 fasta0 25000000 33.610 33.626 1.000 fasta2 100 0.124 0.124 1.000 fasta2 250000 0.408 0.396 1.030 fasta2 25000000 33.362 33.294 1.002 mandelbrot 1000 0.892 0.884 1.009 mandelbrot 4000 14.220 14.040 1.013 mandelbrot 16000 228.082 229.918 0.992 mandelbrot1 1000 1.168 1.176 0.993 mandelbrot1 4000 19.209 19.241 0.998 mandelbrot1 16000 305.999 307.239 0.996 mandelbrot2 1000 1.232 1.212 1.017 mandelbrot2 4000 13.024 13.020 1.000 meteor 2098 1.300 1.312 0.991 nbody 500000 0.764 0.804 0.950 nbody 3000000 4.524 4.840 0.935 nbody 5500000 8.396 8.828 0.951 spectral 500 0.356 0.420 0.848 spectral 3000 51.979 53.919 0.964 spectral 5500 185.663 192.423 0.965 almabench 17.261 17.721 0.974 almabench.unsafe 17.317 18.441 0.939 bdd 1.256 1.248 1.006 boyer 1.668 1.672 0.998 fft 3.064 3.080 0.995 nucleic 2.188 2.268 0.965 quicksort 0.340 0.340 1.000 quicksort.unsafe 0.272 0.272 1.000 soli 0.016 0.016 1.000 soli.unsafe 0.008 0.008 1.000 sorts 6.164 6.180 0.997 Testumgebung: ------------- Fujitsu Siemens Primergy server Intel(R) Pentium(R) 4 "Northwood" CPU 2.40GHz (512 KiB L2 Cache) 768 MiB RAM Debian testing 2011/08/15 with Linux/i686 2.6.32-3-686

Index: driver/main_args.mli =================================================================== --- driver/main_args.mli (Revision 29) +++ driver/main_args.mli (Revision 31) @@ -142,6 +142,8 @@ val _warn_help : unit -> unit val _where : unit -> unit + val _linscan : unit -> unit + val _nopervasives : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit @@ -158,6 +160,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -185,6 +188,8 @@ val _warn_error : string -> unit val _warn_help : unit -> unit + val _linscan : unit -> unit + val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit @@ -200,6 +205,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit Index: driver/main_args.ml =================================================================== --- driver/main_args.ml (Revision 29) +++ driver/main_args.ml (Revision 31) @@ -298,6 +298,11 @@ "-use-prims", Arg.String f, "<file> (undocumented)" ;; +let mk_linscan f = + "-linscan", Arg.Unit f, " (undocumented)" +;; + + let mk_dparsetree f = "-dparsetree", Arg.Unit f, " (undocumented)" ;; @@ -362,6 +367,11 @@ "-dlinear", Arg.Unit f, " (undocumented)" ;; +let mk_dinterval f = + "-dinterval", Arg.Unit f, " (undocumented)" +;; + + let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; @@ -499,6 +509,8 @@ val _warn_help : unit -> unit val _where : unit -> unit + val _linscan : unit -> unit + val _nopervasives : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit @@ -515,6 +527,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -542,6 +555,8 @@ val _warn_error : string -> unit val _warn_help : unit -> unit + val _linscan : unit -> unit + val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit @@ -557,6 +572,7 @@ val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -709,6 +725,8 @@ mk_warn_help F._warn_help; mk_where F._where; + mk_linscan F._linscan; + mk_nopervasives F._nopervasives; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; @@ -718,12 +736,14 @@ mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; @@ -753,6 +773,8 @@ mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk_linscan F._linscan; + mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dcmm F._dcmm; @@ -760,12 +782,14 @@ mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; Index: driver/optmain.ml =================================================================== --- driver/optmain.ml (Revision 29) +++ driver/optmain.ml (Revision 31) @@ -142,6 +142,8 @@ let _warn_help = Warnings.help_warnings let _where () = print_standard_library () + let _linscan = set use_linscan + let _nopervasives = set nopervasives let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda @@ -158,6 +160,7 @@ let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = anonymous Index: asmcomp/interval.mli =================================================================== --- asmcomp/interval.mli (Revision 0) +++ asmcomp/interval.mli (Revision 31) @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + + +open Format + + +type range = + { + mutable rbegin : int; + mutable rend : int; + } + +type interval = + { + mutable reg : Reg.t; + mutable ibegin : int; + mutable iend : int; + mutable ranges : range list; + } + + +val all_intervals : unit -> interval list +val all_fixed_intervals: unit -> interval list +val debug_intervals: formatter -> Mach.fundecl -> unit +val build_intervals: Mach.fundecl -> unit +val live_on: interval -> int -> bool +val overlapping_ranges: range -> range -> bool +val overlapping: interval -> interval -> bool +val strip_expired_ranges: range list -> int -> range list Index: asmcomp/asmgen.ml =================================================================== --- asmcomp/asmgen.ml (Revision 29) +++ asmcomp/asmgen.ml (Revision 31) @@ -39,19 +39,32 @@ let rec regalloc ppf round fd = if round > 50 then - fatal_error(fd.Mach.fun_name ^ - ": function too complex, cannot complete register allocation"); + fatal_error(fd.Mach.fun_name ^ + ": function too complex, cannot complete register allocation"); dump_if ppf dump_live "Liveness analysis" fd; - Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf (); - if !dump_prefer then Printmach.preferences ppf (); - Coloring.allocate_registers(); - dump_if ppf dump_regalloc "After register allocation" fd; - let (newfd, redo_regalloc) = Reload.fundecl fd in - dump_if ppf dump_reload "After insertion of reloading code" newfd; - if redo_regalloc then begin - Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd - end else newfd + if !use_linscan then begin + Interval.build_intervals fd; + if !dump_interval then Interval.debug_intervals ppf fd; + Linscan.walk_intervals (Interval.all_intervals ()) (Interval.all_fixed_intervals()) fd; + dump_if ppf dump_regalloc "After register allocation" fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + dump_if ppf dump_reload "After insertion of reloading code" newfd; + if redo_regalloc then begin + Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd + end else newfd + end + else begin + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); + Coloring.allocate_registers(); + dump_if ppf dump_regalloc "After register allocation" fd; + let (newfd, redo_regalloc) = Reload.fundecl fd in + dump_if ppf dump_reload "After insertion of reloading code" newfd; + if redo_regalloc then begin + Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd + end else newfd + end let (++) x f = f x @@ -70,7 +83,7 @@ ++ Split.fundecl ++ pass_dump_if ppf dump_split "After live range splitting" ++ liveness ppf - ++ regalloc ppf 1 + ++ regalloc ppf 1 ++ Linearize.fundecl ++ pass_dump_linear_if ppf dump_linear "Linearized code" ++ Scheduling.fundecl Index: asmcomp/interval.ml =================================================================== --- asmcomp/interval.ml (Revision 0) +++ asmcomp/interval.ml (Revision 31) @@ -0,0 +1,290 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + + +open List +open Mach +open Reg + +type range = + { + mutable rbegin : int; + mutable rend : int; + } + +type interval = + { + mutable reg : Reg.t; + mutable ibegin : int; + mutable iend : int; + mutable ranges : range list; + } + + +let interval_list = ref ([] : interval list) +let fixed_interval_list = ref ([] : interval list) +let all_intervals() = !interval_list +let all_fixed_intervals() = !fixed_interval_list + +let overlapping_ranges r0 r1 = + r0.rend > r1.rbegin && r1.rend > r0.rbegin + + +let overlapping i0 i1 = + + let rec test_ranges r0s r1s = + begin match r0s, r1s with + | [], _ -> false + | _, [] -> false + | r0::r0tl, r1::r1tl -> + if overlapping_ranges r0 r1 then true + else if r0.rend < r1.rend then test_ranges r0tl r1s + else if r0.rend > r1.rend then test_ranges r0s r1tl + else test_ranges r0tl r1tl + end + in + + test_ranges i0.ranges i1.ranges + +let live_on i p = + let rec live_on_ranges r = + begin match r with + | [] -> false + | hd::tl -> + if p < hd.rbegin then false + else if p < hd.rend then true + else live_on_ranges tl + end in + live_on_ranges i.ranges + + +let rec strip_expired_ranges ranges pos = + begin match ranges with + | [] -> [] + | hd::tl -> + if hd.rend > pos then ranges + else strip_expired_ranges tl pos + end + + + + +let debug_intervals ppf fd = + Format.fprintf ppf "*** Intervals\n"; + Format.fprintf ppf "%s\n" fd.fun_name; + + let dump_interval i = + Format.fprintf ppf " "; + Printmach.reg ppf i.reg; + List.iter (fun r -> + Format.fprintf ppf " [%d;%d[ " r.rbegin r.rend + ) i.ranges; + Format.fprintf ppf "\n" + in + List.iter dump_interval !fixed_interval_list; + List.iter dump_interval !interval_list; + () + + +let get_and_initialize_interval intervals reg pos_tst pos_set use_kind = + let interval = intervals.(reg.stamp) in + if interval.iend = 0 then begin + interval.ibegin <- pos_tst; + interval.iend <- pos_set; + interval.reg <- reg; + interval.ranges <- [{rbegin = pos_tst; rend = pos_set; }] + end; + interval + + +let update_interval_position intervals pos_tst pos_set use_kind reg = + let interval = get_and_initialize_interval intervals reg pos_tst pos_set use_kind in + let range = begin match interval.ranges with |[] -> Misc.fatal_error "Illegal empty range" | hd::_ -> hd end in + + interval.iend <- pos_set; + + if (range.rend = pos_tst || (range.rend + 1) = pos_tst) && use_kind != 1 then + range.rend <- pos_set + else if range.rbegin = pos_tst && range.rend = pos_tst && use_kind = 1 then + range.rend <- pos_set + else + interval.ranges <- {rbegin=pos_tst;rend=pos_set;} :: interval.ranges + + + +let update_interval_position_by_reg_array intervals regs pos_tst pos_set use_kind = + Array.iter (update_interval_position intervals pos_tst pos_set use_kind) regs + +let update_interval_position_by_reg_set intervals regs pos_tst pos_set use_kind = + Set.iter (update_interval_position intervals pos_tst pos_set use_kind) regs + +let update_interval_position_by_instr intervals instr pos_tst pos_set = + update_interval_position_by_reg_array intervals instr.arg pos_tst pos_set 0; + update_interval_position_by_reg_array intervals instr.res pos_set pos_set 1; + update_interval_position_by_reg_set intervals instr.live pos_tst pos_set 0 + + +let insert_pos_for_live intervals instr pos = + if (not (Set.is_empty instr.live)) || Array.length instr.arg > 0 then + begin + pos := succ !pos; + update_interval_position_by_reg_set intervals instr.live !pos !pos 0; + update_interval_position_by_reg_array intervals instr.arg !pos !pos 0 + end + +let insert_destroyed_at_oper intervals instr pos = + let destroyed = Proc.destroyed_at_oper instr.desc in + if Array.length destroyed > 0 then + update_interval_position_by_reg_array intervals destroyed pos pos 1 + +let insert_destroyed_at_raise intervals pos = + let destroyed = Proc.destroyed_at_raise in + if Array.length destroyed > 0 then + update_interval_position_by_reg_array intervals destroyed pos pos 1 + + +(* generate all intervals. + the intervals will be expanded by one step at the beginning and + the ending of a basic block +*) +let build_intervals fundecl = + + let intervals = Array.init (Reg.num_registers()) (fun i -> + { reg = Reg.dummy; + ibegin = 0; + iend = 0; + ranges = []; + }) in + + + let rec walk_instruction i pos shift = + pos := !pos + 1 + shift; + update_interval_position_by_instr intervals i (!pos - shift) !pos; + + + begin match i.desc with + | Iend -> + (* end ends a bb *) + insert_pos_for_live intervals i pos; + + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true) | Itailcall_ind | Itailcall_imm _) -> + walk_instruction i.next pos 0 + + | Iop _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next pos 0 + + | Ireturn -> + insert_destroyed_at_oper intervals i !pos; + (* returns ends a bb *) + insert_pos_for_live intervals i pos; + walk_instruction i.next pos 0 + + + | Iifthenelse(test, ifso, ifnot) -> + insert_destroyed_at_oper intervals i !pos; + (* if ends a bb *) + insert_pos_for_live intervals i pos; + + (* ifso starts a new bb *) + walk_instruction ifso pos 1; + + (* ifnot starts a new bb *) + walk_instruction ifnot pos 1; + + (* next starts a new bb *) + walk_instruction i.next pos 1 + | Iswitch(index, cases) -> + insert_destroyed_at_oper intervals i !pos; + (* switch ends a bb *) + insert_pos_for_live intervals i pos; + + for j = 0 to Array.length cases -1 do + (* each case starts a new bb *) + walk_instruction cases.(j) pos 1 + done; + (* next starts a new bb *) + walk_instruction i.next pos 1 + | Iloop body -> + insert_destroyed_at_oper intervals i !pos; + (* loop ends a bb *) + insert_pos_for_live intervals i pos; + + (* the body starts a new block *) + walk_instruction body pos 1; + + (* next starts a new bb *) + walk_instruction i.next pos 1 + | Icatch(io, body, handler) -> + insert_destroyed_at_oper intervals i !pos; + (* catch ends a bb *) + insert_pos_for_live intervals i pos; + + (* the body starts a new bb *) + walk_instruction body pos 1; + + (* the handler starts a new bb *) + walk_instruction handler pos 1; + + (* next starts a new bb *) + walk_instruction i.next pos 1; + | Iexit nfail -> + insert_destroyed_at_oper intervals i !pos; + (* exit ends a bb *) + insert_pos_for_live intervals i pos; + + | Itrywith(body, handler) -> + insert_destroyed_at_oper intervals i !pos; + (* trywith ends a bb *) + insert_pos_for_live intervals i pos; + + (* the body starts a new bb *) + walk_instruction body pos 1; + + (* the handler starts a new bb *) + insert_pos_for_live intervals handler pos; + insert_destroyed_at_raise intervals !pos; + walk_instruction handler pos 0; + + (* nex starts a new bb *) + walk_instruction i.next pos 1 + | Iraise -> + (* raise ends a bb *) + insert_pos_for_live intervals i pos; + + walk_instruction i.next pos 1 + end + + + + in + + let pos = ref 0 in + walk_instruction fundecl.fun_body pos 1; + + + interval_list := []; + fixed_interval_list := []; + Array.iter (fun i -> + if i.iend != 0 then begin + i.ranges <- List.rev i.ranges; + begin match i.reg.loc with + | Reg r -> fixed_interval_list := i :: !fixed_interval_list + | _ -> interval_list := i :: !interval_list + end + end) intervals; + + + interval_list := List.sort (fun i0 i1 -> i0.ibegin - i1.ibegin) !interval_list; + + () Index: asmcomp/linscan.ml =================================================================== --- asmcomp/linscan.ml (Revision 0) +++ asmcomp/linscan.ml (Revision 31) @@ -0,0 +1,295 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + +open Interval +open Clflags +open List +open Format +open Mach + + +type active_t = +{ + mutable active : interval list; + mutable inactive : interval list; + mutable fixed : interval list; +} + + +let active = Array.init Proc.num_register_classes (fun i -> {active = []; inactive = []; fixed= [] }) + +let rec insert_into active current = + begin match active with + | [] -> [current] + | interval::tl -> + (* check code for <= or < *) + if interval.iend <= current.iend then + current :: active + else + interval :: insert_into tl current + end + + +let rec release_expired_fixed pos intervals = + begin match intervals with + | [] -> [] + | interval::tl -> + if interval.iend > pos then begin + interval.ranges <- Interval.strip_expired_ranges interval.ranges pos; + interval :: release_expired_fixed pos tl + end + else + [] + end + + +let rec release_expired_active active_cl pos intervals = + begin match intervals with + | [] -> [] + | interval::tl -> + if interval.iend > pos then begin + interval.ranges <- Interval.strip_expired_ranges interval.ranges pos; + if Interval.live_on interval pos then + interval :: release_expired_active active_cl pos tl + else begin + active_cl.inactive <- insert_into active_cl.inactive interval; + release_expired_active active_cl pos tl + end + end + else + [] + end + +let rec release_expired_inactive active_cl pos intervals = + begin match intervals with + | [] -> [] + | interval::tl -> + if interval.iend > pos then begin + interval.ranges <- Interval.strip_expired_ranges interval.ranges pos; + if not (Interval.live_on interval pos) then + interval :: release_expired_inactive active_cl pos tl + else begin + active_cl.active <- insert_into active_cl.active interval; + release_expired_inactive active_cl pos tl + end + end + else + [] + end + + + + +let get_stack_slot cl = + let nslots = Proc.num_stack_slots.(cl) in + Proc.num_stack_slots.(cl) <- nslots + 1; + nslots + + + +let pop_active active = + begin match active with + | [] -> [] + | _::tl -> tl + end + + +(* find a register for the given interval and assigns this + register. The interval is inserted into active. + If there is no space available for this interval then + nothings happens and false is returned. Otherwise + returns true. + *) +let try_alloc_free_register interval = + let cl = Proc.register_class interval.reg in + (* this intervals has already been spilled *) + if interval.reg.Reg.spill then begin + begin match interval.reg.Reg.loc with + | Reg.Unknown -> interval.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + | _ -> () + end + end; + + let num = Proc.num_available_registers.(cl) in + if interval.reg.Reg.loc != Reg.Unknown then true (* this register is already allocated or spilled *) + else if num = 0 then false (* there are not registers for this class *) + else begin + let first_reg = Proc.first_available_register.(cl) in + let active_cl = active.(cl) in + + (* create array containing all possible free regs *) + let regs = Array.make num true in + + (* remove all assigned registers from the free array *) + let rec remove_bound actives = + begin match actives with + | [] -> () + | i::tl -> + begin + begin match i.reg.Reg.loc with + | Reg.Reg(r) -> regs.(r - first_reg) <- false + | _ -> () + end; + remove_bound tl + end + end + in + + remove_bound active_cl.active; + + (* remove all overlapping registers from the free array *) + let rec remove_bound_overlapping fix = + begin match fix with + | [] -> () + | i::tl -> + begin + begin match i.reg.Reg.loc with + | Reg.Reg(r) -> + if regs.(r-first_reg) && Interval.overlapping i interval then + regs.(r - first_reg) <- false + | _ -> () + end; + remove_bound_overlapping tl + end + end + in + remove_bound_overlapping active_cl.inactive; + remove_bound_overlapping active_cl.fixed; + + + let rec find_first_free_reg c = + if c = num then -1 + else if regs.(c) then c + else find_first_free_reg (c+1) in + + let first_free_reg = find_first_free_reg 0 in + + if first_free_reg = -1 then false + else begin + (* assign the free register *) + interval.reg.Reg.loc <- Reg.Reg (first_reg + first_free_reg); + interval.reg.Reg.spill <- false; + (* and insert the current interval into active *) + active_cl.active <- insert_into active_cl.active interval; + true + end; + end + + +let allocate_blocked_register interval = + let cl = Proc.register_class interval.reg in + let active_cl = active.(cl) in + + + if active_cl.active = [] then begin + (* this is the special case when there are no register at all + in the register class. This can happen e.g. for float Regs on i386 *) + interval.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + interval.reg.Reg.spill <- true + end + else begin + + (* get the latest interval in active *) + let last_active = List.hd active_cl.active in + + if last_active.iend > interval.iend then begin + (* last interval in active ends latest -> spill it*) + + (* transfer the register from the active in the current interval *) + begin match last_active.reg.Reg.loc with + | Reg.Reg r -> interval.reg.Reg.loc <- Reg.Reg r + | _ -> () + end; + + (* remove the latest interval from active ... *) + active_cl.active <- pop_active active_cl.active; + (* ... and insert the current *) + active_cl.active <- insert_into active_cl.active interval; + + (* now get a new stack slot for the spilled register *) + last_active.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + last_active.reg.Reg.spill <- true + end + else begin + (* the current interval ends latest -> spill it *) + interval.reg.Reg.loc <- Reg.Stack(Reg.Local (get_stack_slot cl)); + interval.reg.Reg.spill <- true + end; + end; + () + + +let handle_interval interval = + let position = interval.ibegin in + + (* release all intervals that have been expired at the current step*) + for i = 0 to Proc.num_register_classes - 1 do + let active_cl = active.(i) in + active_cl.active <- release_expired_active active_cl position active_cl.active; + active_cl.inactive <- release_expired_inactive active_cl position active_cl.inactive; + active_cl.fixed <- release_expired_fixed position active_cl.fixed; + done; + + + (* find a register for allocation *) + if not (try_alloc_free_register interval) then + (* a valid free register could not be found, so we have to + decide which interval is to be spilled *) + allocate_blocked_register interval + +(* create active liste for every register class *) +let initialize_interval_lists intervals = + + + for i=0 to Proc.num_register_classes - 1 do + let active_cl = active.(i) in + (* start with empty actives *) + active_cl.active <- []; + active_cl.inactive <- []; + active_cl.fixed <- []; + done; + + (* add all fixed intervals to the list of active_fixed intervals *) + let rec add_fixed_intervals intervals = + begin match intervals with + | [] -> () + | i :: tl -> + let active_cl = active.(Proc.register_class i.reg) in + active_cl.fixed <- i :: active_cl.fixed; + add_fixed_intervals tl + end in + add_fixed_intervals intervals; + + for i = 0 to Proc.num_register_classes - 1 do + let active_cl = active.(i) in + active_cl.fixed <- List.sort (fun i0 i1 -> i1.iend - i0.iend) active_cl.fixed + done + + + + + +let walk_intervals intervals fixed_intervals fd = + (* Initialize the stack slots *) + for i = 0 to Proc.num_register_classes - 1 do + Proc.num_stack_slots.(i) <- 0 + done; + + + (* create the active lists *) + initialize_interval_lists fixed_intervals; + + + (* Walk all the intervals within the list *) + List.iter handle_interval intervals + Index: asmcomp/linscan.mli =================================================================== --- asmcomp/linscan.mli (Revision 0) +++ asmcomp/linscan.mli (Revision 31) @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach *) +(* *) +(* Copyright 2011 University of Siegen. All rights reserved. *) +(* This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + + +val walk_intervals: Interval.interval list -> Interval.interval list -> Mach.fundecl -> unit + Index: Makefile =================================================================== --- Makefile (Revision 29) +++ Makefile (Revision 31) @@ -79,6 +79,7 @@ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo Index: toplevel/opttopmain.ml =================================================================== --- toplevel/opttopmain.ml (Revision 29) +++ toplevel/opttopmain.ml (Revision 31) @@ -85,6 +85,8 @@ let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings + let _linscan = set use_linscan + let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda @@ -100,6 +102,7 @@ let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = file_argument Index: Makefile.nt =================================================================== --- Makefile.nt (Revision 29) +++ Makefile.nt (Revision 31) @@ -76,6 +76,7 @@ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo Index: utils/clflags.ml =================================================================== --- utils/clflags.ml (Revision 29) +++ utils/clflags.ml (Revision 31) @@ -26,6 +26,7 @@ and make_archive = ref false (* -a *) and debug = ref false (* -g *) and fast = ref false (* -unsafe *) +and use_linscan = ref false (* -linscan *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) @@ -73,6 +74,7 @@ let dump_reload = ref false (* -dreload *) let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) +let dump_interval = ref false (* -dinterval *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) Index: utils/clflags.mli =================================================================== --- utils/clflags.mli (Revision 29) +++ utils/clflags.mli (Revision 31) @@ -23,6 +23,7 @@ val make_archive : bool ref val debug : bool ref val fast : bool ref +val use_linscan : bool ref val link_everything : bool ref val custom_runtime : bool ref val output_c_object : bool ref @@ -67,6 +68,7 @@ val dump_reload : bool ref val dump_scheduling : bool ref val dump_linear : bool ref +val dump_interval : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref

diff --git a/.depend b/.depend index 2c1a795..1ca7f79 100644 --- a/.depend +++ b/.depend @@ -494,7 +494,9 @@ asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/emitaux.cmi: asmcomp/debuginfo.cmi asmcomp/interf.cmi: asmcomp/mach.cmi +asmcomp/interval.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi +asmcomp/linscan.cmi: asmcomp/liveness.cmi: asmcomp/mach.cmi asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo @@ -518,20 +520,22 @@ asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ - asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ - asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \ - asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi + utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi asmcomp/linscan.cmi \ + asmcomp/linearize.cmi asmcomp/interval.cmi asmcomp/interf.cmi \ + asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ + asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ + asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ + asmcomp/asmgen.cmi asmcomp/asmgen.cmx: bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \ - asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ - asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \ - asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi + utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx asmcomp/linscan.cmx \ + asmcomp/linearize.cmx asmcomp/interval.cmx asmcomp/interf.cmx \ + asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ + asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ + asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ + asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo: utils/misc.cmi utils/config.cmi \ asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \ asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ @@ -634,12 +638,20 @@ asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/interf.cmi +asmcomp/interval.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/interval.cmi +asmcomp/interval.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ + asmcomp/mach.cmx asmcomp/interval.cmi asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/linearize.cmi asmcomp/linearize.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/linearize.cmi +asmcomp/linscan.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/interval.cmi utils/clflags.cmi asmcomp/linscan.cmi +asmcomp/linscan.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/interval.cmx utils/clflags.cmx asmcomp/linscan.cmi asmcomp/liveness.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi asmcomp/liveness.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ @@ -657,11 +669,11 @@ asmcomp/printlinear.cmo: asmcomp/printmach.cmi asmcomp/mach.cmi \ asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi asmcomp/printmach.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi \ - asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/printmach.cmi + asmcomp/mach.cmi asmcomp/interval.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \ - asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/printmach.cmi + asmcomp/mach.cmx asmcomp/interval.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ utils/config.cmi asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo \ asmcomp/proc.cmi diff --git a/Makefile b/Makefile index 912259b..c7b2d72 100644 --- a/Makefile +++ b/Makefile @@ -72,11 +72,11 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ + asmcomp/closure.cmo asmcomp/cmmgen.cmo asmcomp/interval.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ - asmcomp/interf.cmo asmcomp/coloring.cmo \ + asmcomp/interf.cmo asmcomp/coloring.cmo asmcomp/linscan.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ diff --git a/Makefile.nt b/Makefile.nt index a7e34f5..7e9c291 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -76,6 +76,7 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 9cdf61f..78e36ef 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -42,10 +42,18 @@ let rec regalloc ppf round fd = fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); dump_if ppf dump_live "Liveness analysis" fd; - Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf (); - if !dump_prefer then Printmach.preferences ppf (); - Coloring.allocate_registers(); + if !use_linscan then begin + (* Linear Scan *) + Interval.build_intervals fd; + if !dump_interval then Printmach.intervals ppf (); + Linscan.allocate_registers() + end else begin + (* Graph Coloring *) + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); + Coloring.allocate_registers() + end; dump_if ppf dump_regalloc "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in dump_if ppf dump_reload "After insertion of reloading code" newfd; diff --git a/asmcomp/interval.ml b/asmcomp/interval.ml new file mode 100644 index 0000000..6ace2e6 --- /dev/null +++ b/asmcomp/interval.ml @@ -0,0 +1,224 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Live intervals for the linear scan register allocator. *) + +open List +open Mach +open Reg + +type range = + { + mutable rbegin: int; + mutable rend: int; + } + +type t = + { + mutable reg: Reg.t; + mutable ibegin: int; + mutable iend: int; + mutable ranges: range list; + } + +let interval_list = ref ([] : t list) +let fixed_interval_list = ref ([] : t list) +let all_intervals() = !interval_list +let all_fixed_intervals() = !fixed_interval_list + +(* Check if two intervals overlap *) + +let overlap i0 i1 = + let rec overlap_ranges rl0 rl1 = + match rl0, rl1 with + r0 :: rl0', r1 :: rl1' -> + if r0.rend > r1.rbegin && r1.rend > r0.rbegin then true + else if r0.rend < r1.rend then overlap_ranges rl0' rl1 + else if r0.rend > r1.rend then overlap_ranges rl0 rl1' + else overlap_ranges rl0' rl1' + | _ -> false in + overlap_ranges i0.ranges i1.ranges + +let is_live i pos = + let rec is_live_in_ranges = function + [] -> false + | r :: rl -> if pos < r.rbegin then false + else if pos < r.rend then true + else is_live_in_ranges rl in + is_live_in_ranges i.ranges + +let remove_expired_ranges i pos = + let rec filter = function + [] -> [] + | r :: rl' as rl -> if pos < r.rend then rl + else filter rl' in + i.ranges <- filter i.ranges + +let update_interval_position intervals pos_tst pos_set use_kind reg = + let i = intervals.(reg.stamp) in + if i.iend == 0 then begin + i.ibegin <- pos_tst; + i.iend <- pos_set; + i.reg <- reg; + i.ranges <- [{rbegin = pos_tst; rend = pos_set}] + end; + match i.ranges with + [] -> + Misc.fatal_error "Illegal empty range" + | range :: _ -> + i.iend <- pos_set; + if (range.rend == pos_tst || (range.rend + 1) == pos_tst) && use_kind != 1 then + range.rend <- pos_set + else if range.rbegin == pos_tst && range.rend == pos_tst && use_kind == 1 then + range.rend <- pos_set + else + i.ranges <- {rbegin = pos_tst; rend = pos_set} :: i.ranges + +let update_interval_position_by_array intervals regs pos_tst pos_set use_kind = + Array.iter (update_interval_position intervals pos_tst pos_set use_kind) regs + +let update_interval_position_by_set intervals regs pos_tst pos_set use_kind = + Set.iter (update_interval_position intervals pos_tst pos_set use_kind) regs + +let update_interval_position_by_instr intervals instr pos_tst pos_set = + update_interval_position_by_array intervals instr.arg pos_tst pos_set 0; + update_interval_position_by_array intervals instr.res pos_set pos_set 1; + update_interval_position_by_set intervals instr.live pos_tst pos_set 0 + +let insert_pos_for_live intervals instr pos = + if (not (Set.is_empty instr.live)) || Array.length instr.arg > 0 then + begin + pos := succ !pos; + update_interval_position_by_set intervals instr.live !pos !pos 0; + update_interval_position_by_array intervals instr.arg !pos !pos 0 + end + +let insert_destroyed_at_oper intervals instr pos = + let destroyed = Proc.destroyed_at_oper instr.desc in + if Array.length destroyed > 0 then + update_interval_position_by_array intervals destroyed pos pos 1 + +let insert_destroyed_at_raise intervals pos = + let destroyed = Proc.destroyed_at_raise in + if Array.length destroyed > 0 then + update_interval_position_by_array intervals destroyed pos pos 1 + +(* Build all intervals. + The intervals will be expanded by one step at the start and end + of a basic block. *) + +let build_intervals fd = + let intervals = Array.init + (Reg.num_registers()) + (fun _ -> { + reg = Reg.dummy; + ibegin = 0; + iend = 0; + ranges = []; }) in + let pos = ref 0 in + let rec walk_instruction i shift = + pos := !pos + 1 + shift; + update_interval_position_by_instr intervals i (!pos - shift) !pos; + begin match i.desc with + Iend -> + (* Iend ends a basic block *) + insert_pos_for_live intervals i pos + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true) + | Itailcall_ind | Itailcall_imm _) -> + walk_instruction i.next 0 + | Iop _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next 0 + | Ireturn -> + insert_destroyed_at_oper intervals i !pos; + (* Ireturn ends a basic block *) + insert_pos_for_live intervals i pos; + walk_instruction i.next 0 + | Iifthenelse(_, ifso, ifnot) -> + insert_destroyed_at_oper intervals i !pos; + (* Iifthenelse ends a basic block *) + insert_pos_for_live intervals i pos; + (* ifso starts a new basic block *) + walk_instruction ifso 1; + (* ifnot starts a new basic block *) + walk_instruction ifnot 1; + (* next starts a new basic block *) + walk_instruction i.next 1 + | Iswitch(_, cases) -> + insert_destroyed_at_oper intervals i !pos; + (* Iswitch ends a basic block *) + insert_pos_for_live intervals i pos; + (* Each case starts a new basic block *) + Array.iter (fun case -> walk_instruction case 1) cases; + (* next starts a new basic block *) + walk_instruction i.next 1 + | Iloop body -> + insert_destroyed_at_oper intervals i !pos; + (* Iloop ends a basic block *) + insert_pos_for_live intervals i pos; + (* body starts a new basic block *) + walk_instruction body 1; + (* next starts a new basic block *) + walk_instruction i.next 1 + | Icatch(_, body, handler) -> + insert_destroyed_at_oper intervals i !pos; + (* Icatch ends a basic block *) + insert_pos_for_live intervals i pos; + (* body starts a new basic block *) + walk_instruction body 1; + (* handler starts a new basic block *) + walk_instruction handler 1; + (* next starts a new basic block *) + walk_instruction i.next 1 + | Iexit _ -> + insert_destroyed_at_oper intervals i !pos; + (* Iexit ends a basic block *) + insert_pos_for_live intervals i pos + | Itrywith(body, handler) -> + insert_destroyed_at_oper intervals i !pos; + (* Itrywith ends a basic block *) + insert_pos_for_live intervals i pos; + (* body starts a new basic block *) + walk_instruction body 1; + (* handler starts a new basic block *) + insert_pos_for_live intervals handler pos; + insert_destroyed_at_raise intervals !pos; + walk_instruction handler 0; + (* nex starts a new basic block *) + walk_instruction i.next 1 + | Iraise -> + (* Iraise ends a basic block *) + insert_pos_for_live intervals i pos; + (* next starts a new basic block *) + walk_instruction i.next 1 + end in + walk_instruction fd.fun_body 1; + (* Generate the interval and fixed interval lists *) + interval_list := []; + fixed_interval_list := []; + Array.iter + (fun i -> + if i.iend != 0 then begin + i.ranges <- List.rev i.ranges; + begin match i.reg.loc with + Reg _ -> + fixed_interval_list := i :: !fixed_interval_list + | _ -> + interval_list := i :: !interval_list + end + end) + intervals; + (* Sort the intervals according to their start position *) + interval_list := List.sort (fun i0 i1 -> i0.ibegin - i1.ibegin) !interval_list diff --git a/asmcomp/interval.mli b/asmcomp/interval.mli new file mode 100644 index 0000000..af4538d --- /dev/null +++ b/asmcomp/interval.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Live intervals for the linear scan register allocator. *) + +type range = + { + mutable rbegin: int; + mutable rend: int; + } + +type t = + { + mutable reg: Reg.t; + mutable ibegin: int; + mutable iend: int; + mutable ranges: range list; + } + +val all_intervals: unit -> t list +val all_fixed_intervals: unit -> t list +val overlap: t -> t -> bool +val is_live: t -> int -> bool +val remove_expired_ranges: t -> int -> unit +val build_intervals: Mach.fundecl -> unit diff --git a/asmcomp/linscan.ml b/asmcomp/linscan.ml new file mode 100644 index 0000000..9493732 --- /dev/null +++ b/asmcomp/linscan.ml @@ -0,0 +1,194 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Linear scan register allocation. *) + +open Interval +open Clflags +open List +open Format +open Mach +open Reg + +(* Live intervals per register class *) + +type class_intervals = + { + mutable ci_fixed: Interval.t list; + mutable ci_active: Interval.t list; + mutable ci_inactive: Interval.t list; + } + +let active = Array.init Proc.num_register_classes (fun _ -> { + ci_fixed = []; + ci_active = []; + ci_inactive = [] +}) + +(* Insert interval into list sorted by end position *) + +let rec insert_interval_sorted i = function + [] -> [i] + | j :: _ as il when j.iend <= i.iend -> i :: il + | j :: il -> j :: insert_interval_sorted i il + +let rec release_expired_fixed pos = function + i :: il when i.iend > pos -> + Interval.remove_expired_ranges i pos; + i :: release_expired_fixed pos il + | _ -> [] + +let rec release_expired_active ci pos = function + i :: il when i.iend > pos -> + Interval.remove_expired_ranges i pos; + if Interval.is_live i pos then + i :: release_expired_active ci pos il + else begin + ci.ci_inactive <- insert_interval_sorted i ci.ci_inactive; + release_expired_active ci pos il + end + | _ -> [] + +let rec release_expired_inactive ci pos = function + i :: il when i.iend > pos -> + Interval.remove_expired_ranges i pos; + if not (Interval.is_live i pos) then + i :: release_expired_inactive ci pos il + else begin + ci.ci_active <- insert_interval_sorted i ci.ci_active; + release_expired_inactive ci pos il + end + | _ -> [] + +(* Allocate a new stack slot to the interval. *) + +let allocate_stack_slot i = + let cl = Proc.register_class i.reg in + let ss = Proc.num_stack_slots.(cl) in + Proc.num_stack_slots.(cl) <- succ ss; + i.reg.loc <- Stack(Local ss); + i.reg.spill <- true + +(* Find a register for the given interval and assigns this register. + The interval is added to active. Raises Not_found if no free registers + left. *) + +let allocate_free_register i = + begin match i.reg.loc, i.reg.spill with + Unknown, true -> + (* Allocate a stack slot for the already spilled interval *) + allocate_stack_slot i + | Unknown, _ -> + (* We need to allocate a register to this interval somehow *) + let cl = Proc.register_class i.reg in + begin match Proc.num_available_registers.(cl) with + 0 -> + (* There are no registers available for this class *) + raise Not_found + | rn -> + let ci = active.(cl) in + let r0 = Proc.first_available_register.(cl) in + (* Create register mask for this class *) + let regmask = Array.make rn true in + (* Remove all assigned registers from the register mask *) + List.iter + (function + {reg = {loc = Reg r}} -> regmask.(r - r0) <- false + | _ -> ()) + ci.ci_active; + (* Remove all overlapping registers from the register mask *) + let remove_bound_overlapping = function + {reg = {loc = Reg r}} as j -> + if regmask.(r - r0) && Interval.overlap j i then + regmask.(r - r0) <- false + | _ -> () in + List.iter remove_bound_overlapping ci.ci_inactive; + List.iter remove_bound_overlapping ci.ci_fixed; + (* Assign the first free register (if any) *) + let rec assign r = + if r = rn then + raise Not_found + else if regmask.(r) then begin + (* Assign the free register and insert the + current interval into the active list *) + i.reg.loc <- Reg (r0 + r); + i.reg.spill <- false; + ci.ci_active <- insert_interval_sorted i ci.ci_active + end else + assign (succ r) in + assign 0 + end + | _ -> () + end + +let allocate_blocked_register i = + let cl = Proc.register_class i.reg in + let ci = active.(cl) in + begin match ci.ci_active with + ilast :: il when ilast.iend > i.iend -> + (* Last interval in active is the last interval, so spill it. *) + begin match ilast.reg.loc with + Reg _ as loc -> + (* Use register from last interval for current interval *) + i.reg.loc <- loc + | _ -> () + end; + (* Remove the last interval from active and insert the current *) + ci.ci_active <- insert_interval_sorted i il; + (* Now get a new stack slot for the spilled register *) + allocate_stack_slot ilast + | _ -> + (* Either the current interval is last and we have to spill it, + or there are no registers at all in the register class (i.e. + floating point class on i386). *) + allocate_stack_slot i + end + +let walk_interval i = + let pos = i.ibegin in + (* Release all intervals that have been expired at the current position *) + Array.iter + (fun ci -> + ci.ci_fixed <- release_expired_fixed pos ci.ci_fixed; + ci.ci_active <- release_expired_active ci pos ci.ci_active; + ci.ci_inactive <- release_expired_inactive ci pos ci.ci_inactive) + active; + try + (* Allocate free register (if any) *) + allocate_free_register i + with + Not_found -> + (* No free register, need to decide which interval to spill *) + allocate_blocked_register i + +let allocate_registers() = + (* Initialize the stack slots and interval lists *) + for cl = 0 to Proc.num_register_classes - 1 do + (* Start with empty interval lists *) + active.(cl) <- { + ci_fixed = []; + ci_active = []; + ci_inactive = [] + }; + Proc.num_stack_slots.(cl) <- 0 + done; + (* Add all fixed intervals (sorted by end position) *) + List.iter + (fun i -> + let ci = active.(Proc.register_class i.reg) in + ci.ci_fixed <- insert_interval_sorted i ci.ci_fixed) + (Interval.all_fixed_intervals()); + (* Walk all the intervals within the list *) + List.iter walk_interval (Interval.all_intervals()) diff --git a/asmcomp/linscan.mli b/asmcomp/linscan.mli new file mode 100644 index 0000000..4cee154c --- /dev/null +++ b/asmcomp/linscan.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Linear scan register allocation. *) + +val allocate_registers: unit -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index d7d538d..04da97d 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -18,6 +18,7 @@ open Format open Cmm open Reg open Mach +open Interval let reg ppf r = if String.length r.name > 0 then @@ -207,6 +208,18 @@ let interferences ppf () = fprintf ppf "*** Interferences@."; List.iter (interference ppf) (Reg.all_registers()) +let interval ppf i = + let interv ppf = + List.iter + (fun r -> fprintf ppf "@ [%d;%d[" r.rbegin r.rend) + i.ranges in + fprintf ppf "@[<2>%a:%t@]@." reg i.reg interv + +let intervals ppf () = + fprintf ppf "*** Intervals@."; + List.iter (interval ppf) (Interval.all_fixed_intervals()); + List.iter (interval ppf) (Interval.all_intervals()) + let preference ppf r = let prefs ppf = List.iter diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli index 2832870..43d4871 100644 --- a/asmcomp/printmach.mli +++ b/asmcomp/printmach.mli @@ -26,6 +26,7 @@ val instr: formatter -> Mach.instruction -> unit val fundecl: formatter -> Mach.fundecl -> unit val phase: string -> formatter -> Mach.fundecl -> unit val interferences: formatter -> unit -> unit +val intervals: formatter -> unit -> unit val preferences: formatter -> unit -> unit val print_live: bool ref diff --git a/driver/main_args.ml b/driver/main_args.ml index 279a463..7b60193 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -121,6 +121,10 @@ let mk_linkall f = "-linkall", Arg.Unit f, " Link all modules, even unused ones" ;; +let mk_linscan f = + "-linscan", Arg.Unit f, " Use the linear scan register allocator" +;; + let mk_make_runtime f = "-make-runtime", Arg.Unit f, " Build a runtime system with given C objects and libraries" @@ -362,6 +366,11 @@ let mk_dlinear f = "-dlinear", Arg.Unit f, " (undocumented)" ;; +let mk_dinterval f = + "-dinterval", Arg.Unit f, " (undocumented)" +;; + + let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; @@ -472,6 +481,7 @@ module type Optcomp_options = sig val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit @@ -515,6 +525,7 @@ module type Optcomp_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -526,6 +537,7 @@ module type Opttop_options = sig val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit @@ -557,6 +569,7 @@ module type Opttop_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -682,6 +695,7 @@ struct mk_intf_suffix F._intf_suffix; mk_labels F._labels; mk_linkall F._linkall; + mk_linscan F._linscan; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; @@ -718,12 +732,14 @@ struct mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; @@ -737,6 +753,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_init F._init; mk_inline F._inline; mk_labels F._labels; + mk_linscan F._linscan; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_nolabels F._nolabels; @@ -760,12 +777,14 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; diff --git a/driver/main_args.mli b/driver/main_args.mli index 1c4abf5..f441507 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -115,6 +115,7 @@ module type Optcomp_options = sig val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit @@ -158,6 +159,7 @@ module type Optcomp_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -169,6 +171,7 @@ module type Opttop_options = sig val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit @@ -200,6 +203,7 @@ module type Opttop_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 1c7352c..1db63d5 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -115,6 +115,7 @@ module Options = Main_args.Make_optcomp_options (struct let _intf_suffix s = Config.interface_suffix := s let _labels = clear classic let _linkall = set link_everything + let _linscan = set use_linscan let _no_app_funct = clear applicative_functors let _noassert = set noassert let _noautolink = set no_auto_link @@ -158,6 +159,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = anonymous diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index 583680d..d8d84b9 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -71,6 +71,7 @@ OTHEROBJS=\ $(TOPDIR)/asmcomp/compilenv.cmo \ $(TOPDIR)/asmcomp/closure.cmo \ $(TOPDIR)/asmcomp/cmmgen.cmo \ + $(TOPDIR)/asmcomp/interval.cmo \ $(TOPDIR)/asmcomp/printmach.cmo \ $(TOPDIR)/asmcomp/selectgen.cmo \ $(TOPDIR)/asmcomp/selection.cmo \ @@ -80,6 +81,7 @@ OTHEROBJS=\ $(TOPDIR)/asmcomp/split.cmo \ $(TOPDIR)/asmcomp/interf.cmo \ $(TOPDIR)/asmcomp/coloring.cmo \ + $(TOPDIR)/asmcomp/linscan.cmo \ $(TOPDIR)/asmcomp/reloadgen.cmo \ $(TOPDIR)/asmcomp/reload.cmo \ $(TOPDIR)/asmcomp/printlinear.cmo \ diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index bd27abb..f639d37 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -69,6 +69,7 @@ module Options = Main_args.Make_opttop_options (struct let _init s = init_file := Some s let _inline n = inline_threshold := n * 8 let _labels = clear classic + let _linscan = set use_linscan let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic @@ -100,6 +101,7 @@ module Options = Main_args.Make_opttop_options (struct let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = file_argument diff --git a/utils/clflags.ml b/utils/clflags.ml index 1074d36..63d39a1 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -26,6 +26,7 @@ and print_types = ref false (* -i *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) and fast = ref false (* -unsafe *) +and use_linscan = ref false (* -linscan *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) @@ -73,6 +74,7 @@ let dump_regalloc = ref false (* -dalloc *) let dump_reload = ref false (* -dreload *) let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) +let dump_interval = ref false (* -dinterval *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) diff --git a/utils/clflags.mli b/utils/clflags.mli index d5357ef..0cbf8e3 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -23,6 +23,7 @@ val print_types : bool ref val make_archive : bool ref val debug : bool ref val fast : bool ref +val use_linscan : bool ref val link_everything : bool ref val custom_runtime : bool ref val output_c_object : bool ref @@ -67,6 +68,7 @@ val dump_regalloc : bool ref val dump_reload : bool ref val dump_scheduling : bool ref val dump_linear : bool ref +val dump_interval : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref

diff --git a/.depend b/.depend index 2c1a795..1ca7f79 100644 --- a/.depend +++ b/.depend @@ -494,7 +494,9 @@ asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/emitaux.cmi: asmcomp/debuginfo.cmi asmcomp/interf.cmi: asmcomp/mach.cmi +asmcomp/interval.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi +asmcomp/linscan.cmi: asmcomp/liveness.cmi: asmcomp/mach.cmi asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo @@ -518,20 +520,22 @@ asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ - asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ - asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \ - asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi + utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi asmcomp/linscan.cmi \ + asmcomp/linearize.cmi asmcomp/interval.cmi asmcomp/interf.cmi \ + asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ + asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ + asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ + asmcomp/asmgen.cmi asmcomp/asmgen.cmx: bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \ - asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ - asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \ - asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi + utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx asmcomp/linscan.cmx \ + asmcomp/linearize.cmx asmcomp/interval.cmx asmcomp/interf.cmx \ + asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ + asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ + asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ + asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo: utils/misc.cmi utils/config.cmi \ asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \ asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ @@ -634,12 +638,20 @@ asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/interf.cmi +asmcomp/interval.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/interval.cmi +asmcomp/interval.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ + asmcomp/mach.cmx asmcomp/interval.cmi asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/linearize.cmi asmcomp/linearize.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/linearize.cmi +asmcomp/linscan.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/interval.cmi utils/clflags.cmi asmcomp/linscan.cmi +asmcomp/linscan.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/interval.cmx utils/clflags.cmx asmcomp/linscan.cmi asmcomp/liveness.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi asmcomp/liveness.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ @@ -657,11 +669,11 @@ asmcomp/printlinear.cmo: asmcomp/printmach.cmi asmcomp/mach.cmi \ asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi asmcomp/printmach.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi \ - asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/printmach.cmi + asmcomp/mach.cmi asmcomp/interval.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \ - asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/printmach.cmi + asmcomp/mach.cmx asmcomp/interval.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ utils/config.cmi asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo \ asmcomp/proc.cmi diff --git a/Makefile b/Makefile index 912259b..3d25435 100644 --- a/Makefile +++ b/Makefile @@ -72,11 +72,11 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ + asmcomp/closure.cmo asmcomp/cmmgen.cmo asmcomp/interval.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ - asmcomp/interf.cmo asmcomp/coloring.cmo \ + asmcomp/interf.cmo asmcomp/coloring.cmo asmcomp/linscan.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ diff --git a/Makefile.nt b/Makefile.nt index a7e34f5..7e9c291 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -76,6 +76,7 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 9cdf61f..78e36ef 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -42,10 +42,18 @@ let rec regalloc ppf round fd = fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); dump_if ppf dump_live "Liveness analysis" fd; - Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf (); - if !dump_prefer then Printmach.preferences ppf (); - Coloring.allocate_registers(); + if !use_linscan then begin + (* Linear Scan *) + Interval.build_intervals fd; + if !dump_interval then Printmach.intervals ppf (); + Linscan.allocate_registers() + end else begin + (* Graph Coloring *) + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); + Coloring.allocate_registers() + end; dump_if ppf dump_regalloc "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in dump_if ppf dump_reload "After insertion of reloading code" newfd; diff --git a/asmcomp/interval.ml b/asmcomp/interval.ml new file mode 100644 index 0000000..736edef --- /dev/null +++ b/asmcomp/interval.ml @@ -0,0 +1,188 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Live intervals for the linear scan register allocator. *) + +open List +open Mach +open Reg + +type range = + { + mutable rbegin: int; + mutable rend: int; + } + +type t = + { + mutable reg: Reg.t; + mutable ibegin: int; + mutable iend: int; + mutable ranges: range list; + } + +type kind = + Result + | Argument + | Live + +let interval_list = ref ([] : t list) +let fixed_interval_list = ref ([] : t list) +let all_intervals() = !interval_list +let all_fixed_intervals() = !fixed_interval_list + +(* Check if two intervals overlap *) + +let overlap i0 i1 = + let rec overlap_ranges rl0 rl1 = + match rl0, rl1 with + r0 :: rl0', r1 :: rl1' -> + if r0.rend >= r1.rbegin && r1.rend >= r0.rbegin then true + else if r0.rend < r1.rend then overlap_ranges rl0' rl1 + else if r0.rend > r1.rend then overlap_ranges rl0 rl1' + else overlap_ranges rl0' rl1' + | _ -> false in + overlap_ranges i0.ranges i1.ranges + +let is_live i pos = + let rec is_live_in_ranges = function + [] -> false + | r :: rl -> if pos < r.rbegin then false + else if pos <= r.rend then true + else is_live_in_ranges rl in + is_live_in_ranges i.ranges + +let remove_expired_ranges i pos = + let rec filter = function + [] -> [] + | r :: rl' as rl -> if pos < r.rend then rl + else filter rl' in + i.ranges <- filter i.ranges + +let update_interval_position intervals pos kind reg = + let i = intervals.(reg.stamp) in + let on = pos lsl 1 in + let off = on + 1 in + let rbegin = (match kind with Result -> off | _ -> on) in + let rend = (match kind with Argument -> on | _ -> off) in + if i.iend == 0 then begin + i.ibegin <- off; + i.reg <- reg; + i.ranges <- [{rbegin = rbegin; rend = rend}] + end else begin + let r = List.hd i.ranges in + if r.rend == on - 1 || r.rend == on - 2 then + r.rend <- rend + else + i.ranges <- {rbegin = rbegin; rend = rend} :: i.ranges + end; + i.iend <- rend + +let update_interval_position_by_array intervals regs pos kind = + Array.iter (update_interval_position intervals pos kind) regs + +let update_interval_position_by_set intervals regs pos kind = + Set.iter (update_interval_position intervals pos kind) regs + +let update_interval_position_by_instr intervals instr pos = + update_interval_position_by_array intervals instr.arg pos Argument; + update_interval_position_by_array intervals instr.res pos Result; + update_interval_position_by_set intervals instr.live pos Live + +let insert_destroyed_at_oper intervals instr pos = + let destroyed = Proc.destroyed_at_oper instr.desc in + if Array.length destroyed > 0 then + update_interval_position_by_array intervals destroyed pos Result + +let insert_destroyed_at_raise intervals pos = + let destroyed = Proc.destroyed_at_raise in + if Array.length destroyed > 0 then + update_interval_position_by_array intervals destroyed pos Result + +(* Build all intervals. + The intervals will be expanded by one step at the start and end + of a basic block. *) + +let build_intervals fd = + let intervals = Array.init + (Reg.num_registers()) + (fun _ -> { + reg = Reg.dummy; + ibegin = 0; + iend = 0; + ranges = []; }) in + let pos = ref 0 in + let rec walk_instruction i = + incr pos; + update_interval_position_by_instr intervals i !pos; + begin match i.desc with + Iend -> () + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true) + | Itailcall_ind | Itailcall_imm _) -> + walk_instruction i.next + | Iop _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next + | Ireturn -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next + | Iifthenelse(_, ifso, ifnot) -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction ifso; + walk_instruction ifnot; + walk_instruction i.next + | Iswitch(_, cases) -> + insert_destroyed_at_oper intervals i !pos; + Array.iter walk_instruction cases; + walk_instruction i.next + | Iloop body -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction body; + walk_instruction i.next + | Icatch(_, body, handler) -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction body; + walk_instruction handler; + walk_instruction i.next + | Iexit _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next + | Itrywith(body, handler) -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction body; + insert_destroyed_at_raise intervals !pos; + walk_instruction handler; + walk_instruction i.next + | Iraise -> + walk_instruction i.next + end in + walk_instruction fd.fun_body; + (* Generate the interval and fixed interval lists *) + interval_list := []; + fixed_interval_list := []; + Array.iter + (fun i -> + if i.iend != 0 then begin + i.ranges <- List.rev i.ranges; + begin match i.reg.loc with + Reg _ -> + fixed_interval_list := i :: !fixed_interval_list + | _ -> + interval_list := i :: !interval_list + end + end) + intervals; + (* Sort the intervals according to their start position *) + interval_list := List.sort (fun i0 i1 -> i0.ibegin - i1.ibegin) !interval_list diff --git a/asmcomp/interval.mli b/asmcomp/interval.mli new file mode 100644 index 0000000..af4538d --- /dev/null +++ b/asmcomp/interval.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Live intervals for the linear scan register allocator. *) + +type range = + { + mutable rbegin: int; + mutable rend: int; + } + +type t = + { + mutable reg: Reg.t; + mutable ibegin: int; + mutable iend: int; + mutable ranges: range list; + } + +val all_intervals: unit -> t list +val all_fixed_intervals: unit -> t list +val overlap: t -> t -> bool +val is_live: t -> int -> bool +val remove_expired_ranges: t -> int -> unit +val build_intervals: Mach.fundecl -> unit diff --git a/asmcomp/linscan.ml b/asmcomp/linscan.ml new file mode 100644 index 0000000..01777ef --- /dev/null +++ b/asmcomp/linscan.ml @@ -0,0 +1,194 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Linear scan register allocation. *) + +open Interval +open Clflags +open List +open Format +open Mach +open Reg + +(* Live intervals per register class *) + +type class_intervals = + { + mutable ci_fixed: Interval.t list; + mutable ci_active: Interval.t list; + mutable ci_inactive: Interval.t list; + } + +let active = Array.init Proc.num_register_classes (fun _ -> { + ci_fixed = []; + ci_active = []; + ci_inactive = [] +}) + +(* Insert interval into list sorted by end position *) + +let rec insert_interval_sorted i = function + [] -> [i] + | j :: _ as il when j.iend <= i.iend -> i :: il + | j :: il -> j :: insert_interval_sorted i il + +let rec release_expired_fixed pos = function + i :: il when i.iend >= pos -> + Interval.remove_expired_ranges i pos; + i :: release_expired_fixed pos il + | _ -> [] + +let rec release_expired_active ci pos = function + i :: il when i.iend >= pos -> + Interval.remove_expired_ranges i pos; + if Interval.is_live i pos then + i :: release_expired_active ci pos il + else begin + ci.ci_inactive <- insert_interval_sorted i ci.ci_inactive; + release_expired_active ci pos il + end + | _ -> [] + +let rec release_expired_inactive ci pos = function + i :: il when i.iend >= pos -> + Interval.remove_expired_ranges i pos; + if not (Interval.is_live i pos) then + i :: release_expired_inactive ci pos il + else begin + ci.ci_active <- insert_interval_sorted i ci.ci_active; + release_expired_inactive ci pos il + end + | _ -> [] + +(* Allocate a new stack slot to the interval. *) + +let allocate_stack_slot i = + let cl = Proc.register_class i.reg in + let ss = Proc.num_stack_slots.(cl) in + Proc.num_stack_slots.(cl) <- succ ss; + i.reg.loc <- Stack(Local ss); + i.reg.spill <- true + +(* Find a register for the given interval and assigns this register. + The interval is added to active. Raises Not_found if no free registers + left. *) + +let allocate_free_register i = + begin match i.reg.loc, i.reg.spill with + Unknown, true -> + (* Allocate a stack slot for the already spilled interval *) + allocate_stack_slot i + | Unknown, _ -> + (* We need to allocate a register to this interval somehow *) + let cl = Proc.register_class i.reg in + begin match Proc.num_available_registers.(cl) with + 0 -> + (* There are no registers available for this class *) + raise Not_found + | rn -> + let ci = active.(cl) in + let r0 = Proc.first_available_register.(cl) in + (* Create register mask for this class *) + let regmask = Array.make rn true in + (* Remove all assigned registers from the register mask *) + List.iter + (function + {reg = {loc = Reg r}} -> regmask.(r - r0) <- false + | _ -> ()) + ci.ci_active; + (* Remove all overlapping registers from the register mask *) + let remove_bound_overlapping = function + {reg = {loc = Reg r}} as j -> + if regmask.(r - r0) && Interval.overlap j i then + regmask.(r - r0) <- false + | _ -> () in + List.iter remove_bound_overlapping ci.ci_inactive; + List.iter remove_bound_overlapping ci.ci_fixed; + (* Assign the first free register (if any) *) + let rec assign r = + if r = rn then + raise Not_found + else if regmask.(r) then begin + (* Assign the free register and insert the + current interval into the active list *) + i.reg.loc <- Reg (r0 + r); + i.reg.spill <- false; + ci.ci_active <- insert_interval_sorted i ci.ci_active + end else + assign (succ r) in + assign 0 + end + | _ -> () + end + +let allocate_blocked_register i = + let cl = Proc.register_class i.reg in + let ci = active.(cl) in + begin match ci.ci_active with + ilast :: il when ilast.iend > i.iend -> + (* Last interval in active is the last interval, so spill it. *) + begin match ilast.reg.loc with + Reg _ as loc -> + (* Use register from last interval for current interval *) + i.reg.loc <- loc + | _ -> () + end; + (* Remove the last interval from active and insert the current *) + ci.ci_active <- insert_interval_sorted i il; + (* Now get a new stack slot for the spilled register *) + allocate_stack_slot ilast + | _ -> + (* Either the current interval is last and we have to spill it, + or there are no registers at all in the register class (i.e. + floating point class on i386). *) + allocate_stack_slot i + end + +let walk_interval i = + let pos = i.ibegin land (lnot 0x01) in + (* Release all intervals that have been expired at the current position *) + Array.iter + (fun ci -> + ci.ci_fixed <- release_expired_fixed pos ci.ci_fixed; + ci.ci_active <- release_expired_active ci pos ci.ci_active; + ci.ci_inactive <- release_expired_inactive ci pos ci.ci_inactive) + active; + try + (* Allocate free register (if any) *) + allocate_free_register i + with + Not_found -> + (* No free register, need to decide which interval to spill *) + allocate_blocked_register i + +let allocate_registers() = + (* Initialize the stack slots and interval lists *) + for cl = 0 to Proc.num_register_classes - 1 do + (* Start with empty interval lists *) + active.(cl) <- { + ci_fixed = []; + ci_active = []; + ci_inactive = [] + }; + Proc.num_stack_slots.(cl) <- 0 + done; + (* Add all fixed intervals (sorted by end position) *) + List.iter + (fun i -> + let ci = active.(Proc.register_class i.reg) in + ci.ci_fixed <- insert_interval_sorted i ci.ci_fixed) + (Interval.all_fixed_intervals()); + (* Walk all the intervals within the list *) + List.iter walk_interval (Interval.all_intervals()) diff --git a/asmcomp/linscan.mli b/asmcomp/linscan.mli new file mode 100644 index 0000000..4cee154c --- /dev/null +++ b/asmcomp/linscan.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Linear scan register allocation. *) + +val allocate_registers: unit -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index d7d538d..04da97d 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -18,6 +18,7 @@ open Format open Cmm open Reg open Mach +open Interval let reg ppf r = if String.length r.name > 0 then @@ -207,6 +208,18 @@ let interferences ppf () = fprintf ppf "*** Interferences@."; List.iter (interference ppf) (Reg.all_registers()) +let interval ppf i = + let interv ppf = + List.iter + (fun r -> fprintf ppf "@ [%d;%d[" r.rbegin r.rend) + i.ranges in + fprintf ppf "@[<2>%a:%t@]@." reg i.reg interv + +let intervals ppf () = + fprintf ppf "*** Intervals@."; + List.iter (interval ppf) (Interval.all_fixed_intervals()); + List.iter (interval ppf) (Interval.all_intervals()) + let preference ppf r = let prefs ppf = List.iter diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli index 2832870..43d4871 100644 --- a/asmcomp/printmach.mli +++ b/asmcomp/printmach.mli @@ -26,6 +26,7 @@ val instr: formatter -> Mach.instruction -> unit val fundecl: formatter -> Mach.fundecl -> unit val phase: string -> formatter -> Mach.fundecl -> unit val interferences: formatter -> unit -> unit +val intervals: formatter -> unit -> unit val preferences: formatter -> unit -> unit val print_live: bool ref diff --git a/driver/main_args.ml b/driver/main_args.ml index 279a463..7b60193 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -121,6 +121,10 @@ let mk_linkall f = "-linkall", Arg.Unit f, " Link all modules, even unused ones" ;; +let mk_linscan f = + "-linscan", Arg.Unit f, " Use the linear scan register allocator" +;; + let mk_make_runtime f = "-make-runtime", Arg.Unit f, " Build a runtime system with given C objects and libraries" @@ -362,6 +366,11 @@ let mk_dlinear f = "-dlinear", Arg.Unit f, " (undocumented)" ;; +let mk_dinterval f = + "-dinterval", Arg.Unit f, " (undocumented)" +;; + + let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; @@ -472,6 +481,7 @@ module type Optcomp_options = sig val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit @@ -515,6 +525,7 @@ module type Optcomp_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -526,6 +537,7 @@ module type Opttop_options = sig val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit @@ -557,6 +569,7 @@ module type Opttop_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -682,6 +695,7 @@ struct mk_intf_suffix F._intf_suffix; mk_labels F._labels; mk_linkall F._linkall; + mk_linscan F._linscan; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; @@ -718,12 +732,14 @@ struct mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; @@ -737,6 +753,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_init F._init; mk_inline F._inline; mk_labels F._labels; + mk_linscan F._linscan; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_nolabels F._nolabels; @@ -760,12 +777,14 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; diff --git a/driver/main_args.mli b/driver/main_args.mli index 1c4abf5..f441507 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -115,6 +115,7 @@ module type Optcomp_options = sig val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit @@ -158,6 +159,7 @@ module type Optcomp_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -169,6 +171,7 @@ module type Opttop_options = sig val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit @@ -200,6 +203,7 @@ module type Opttop_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 1c7352c..1db63d5 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -115,6 +115,7 @@ module Options = Main_args.Make_optcomp_options (struct let _intf_suffix s = Config.interface_suffix := s let _labels = clear classic let _linkall = set link_everything + let _linscan = set use_linscan let _no_app_funct = clear applicative_functors let _noassert = set noassert let _noautolink = set no_auto_link @@ -158,6 +159,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = anonymous diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index 583680d..d8d84b9 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -71,6 +71,7 @@ OTHEROBJS=\ $(TOPDIR)/asmcomp/compilenv.cmo \ $(TOPDIR)/asmcomp/closure.cmo \ $(TOPDIR)/asmcomp/cmmgen.cmo \ + $(TOPDIR)/asmcomp/interval.cmo \ $(TOPDIR)/asmcomp/printmach.cmo \ $(TOPDIR)/asmcomp/selectgen.cmo \ $(TOPDIR)/asmcomp/selection.cmo \ @@ -80,6 +81,7 @@ OTHEROBJS=\ $(TOPDIR)/asmcomp/split.cmo \ $(TOPDIR)/asmcomp/interf.cmo \ $(TOPDIR)/asmcomp/coloring.cmo \ + $(TOPDIR)/asmcomp/linscan.cmo \ $(TOPDIR)/asmcomp/reloadgen.cmo \ $(TOPDIR)/asmcomp/reload.cmo \ $(TOPDIR)/asmcomp/printlinear.cmo \ diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index bd27abb..f639d37 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -69,6 +69,7 @@ module Options = Main_args.Make_opttop_options (struct let _init s = init_file := Some s let _inline n = inline_threshold := n * 8 let _labels = clear classic + let _linscan = set use_linscan let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic @@ -100,6 +101,7 @@ module Options = Main_args.Make_opttop_options (struct let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = file_argument diff --git a/utils/clflags.ml b/utils/clflags.ml index 1074d36..63d39a1 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -26,6 +26,7 @@ and print_types = ref false (* -i *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) and fast = ref false (* -unsafe *) +and use_linscan = ref false (* -linscan *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) @@ -73,6 +74,7 @@ let dump_regalloc = ref false (* -dalloc *) let dump_reload = ref false (* -dreload *) let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) +let dump_interval = ref false (* -dinterval *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) diff --git a/utils/clflags.mli b/utils/clflags.mli index d5357ef..0cbf8e3 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -23,6 +23,7 @@ val print_types : bool ref val make_archive : bool ref val debug : bool ref val fast : bool ref +val use_linscan : bool ref val link_everything : bool ref val custom_runtime : bool ref val output_c_object : bool ref @@ -67,6 +68,7 @@ val dump_regalloc : bool ref val dump_reload : bool ref val dump_scheduling : bool ref val dump_linear : bool ref +val dump_interval : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref

diff --git a/Makefile b/Makefile index 912259b..3d25435 100644 --- a/Makefile +++ b/Makefile @@ -72,11 +72,11 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ + asmcomp/closure.cmo asmcomp/cmmgen.cmo asmcomp/interval.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ - asmcomp/interf.cmo asmcomp/coloring.cmo \ + asmcomp/interf.cmo asmcomp/coloring.cmo asmcomp/linscan.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ diff --git a/Makefile.nt b/Makefile.nt index a7e34f5..7e9c291 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -76,6 +76,7 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ + asmcomp/interval.cmo asmcomp/linscan.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 9cdf61f..78e36ef 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -42,10 +42,18 @@ let rec regalloc ppf round fd = fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); dump_if ppf dump_live "Liveness analysis" fd; - Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf (); - if !dump_prefer then Printmach.preferences ppf (); - Coloring.allocate_registers(); + if !use_linscan then begin + (* Linear Scan *) + Interval.build_intervals fd; + if !dump_interval then Printmach.intervals ppf (); + Linscan.allocate_registers() + end else begin + (* Graph Coloring *) + Interf.build_graph fd; + if !dump_interf then Printmach.interferences ppf (); + if !dump_prefer then Printmach.preferences ppf (); + Coloring.allocate_registers() + end; dump_if ppf dump_regalloc "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in dump_if ppf dump_reload "After insertion of reloading code" newfd; diff --git a/asmcomp/interval.ml b/asmcomp/interval.ml new file mode 100644 index 0000000..912672f --- /dev/null +++ b/asmcomp/interval.ml @@ -0,0 +1,189 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Live intervals for the linear scan register allocator. *) + +open List +open Mach +open Reg + +type range = + { + mutable rbegin: int; + mutable rend: int; + } + +type t = + { + mutable reg: Reg.t; + mutable ibegin: int; + mutable iend: int; + mutable ranges: range list; + } + +type kind = + Result + | Argument + | Live + +let interval_list = ref ([] : t list) +let fixed_interval_list = ref ([] : t list) +let all_intervals() = !interval_list +let all_fixed_intervals() = !fixed_interval_list + +(* Check if two intervals overlap *) + +let overlap i0 i1 = + let rec overlap_ranges rl0 rl1 = + match rl0, rl1 with + r0 :: rl0', r1 :: rl1' -> + if r0.rend >= r1.rbegin && r1.rend >= r0.rbegin then true + else if r0.rend < r1.rend then overlap_ranges rl0' rl1 + else if r0.rend > r1.rend then overlap_ranges rl0 rl1' + else overlap_ranges rl0' rl1' + | _ -> false in + overlap_ranges i0.ranges i1.ranges + +let is_live i pos = + let rec is_live_in_ranges = function + [] -> false + | r :: rl -> if pos < r.rbegin then false + else if pos <= r.rend then true + else is_live_in_ranges rl in + is_live_in_ranges i.ranges + +let remove_expired_ranges i pos = + let rec filter = function + [] -> [] + | r :: rl' as rl -> if pos < r.rend then rl + else filter rl' in + i.ranges <- filter i.ranges + +let update_interval_position intervals pos kind reg = + let i = intervals.(reg.stamp) in + let on = pos lsl 1 in + let off = on + 1 in + let rbegin = (match kind with Result -> off | _ -> on) in + let rend = (match kind with Argument -> on | _ -> off) in + if i.iend = 0 then begin + i.ibegin <- rbegin; + i.reg <- reg; + i.ranges <- [{rbegin = rbegin; rend = rend}] + end else begin + let r = List.hd i.ranges in + let ridx = r.rend asr 1 in + if pos - ridx <= 1 then + r.rend <- rend + else + i.ranges <- {rbegin = rbegin; rend = rend} :: i.ranges + end; + i.iend <- rend + +let update_interval_position_by_array intervals regs pos kind = + Array.iter (update_interval_position intervals pos kind) regs + +let update_interval_position_by_set intervals regs pos kind = + Set.iter (update_interval_position intervals pos kind) regs + +let update_interval_position_by_instr intervals instr pos = + update_interval_position_by_array intervals instr.arg pos Argument; + update_interval_position_by_array intervals instr.res pos Result; + update_interval_position_by_set intervals instr.live pos Live + +let insert_destroyed_at_oper intervals instr pos = + let destroyed = Proc.destroyed_at_oper instr.desc in + if Array.length destroyed > 0 then + update_interval_position_by_array intervals destroyed pos Result + +let insert_destroyed_at_raise intervals pos = + let destroyed = Proc.destroyed_at_raise in + if Array.length destroyed > 0 then + update_interval_position_by_array intervals destroyed pos Result + +(* Build all intervals. + The intervals will be expanded by one step at the start and end + of a basic block. *) + +let build_intervals fd = + let intervals = Array.init + (Reg.num_registers()) + (fun _ -> { + reg = Reg.dummy; + ibegin = 0; + iend = 0; + ranges = []; }) in + let pos = ref 0 in + let rec walk_instruction i = + incr pos; + update_interval_position_by_instr intervals i !pos; + begin match i.desc with + Iend -> () + | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true) + | Itailcall_ind | Itailcall_imm _) -> + walk_instruction i.next + | Iop _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next + | Ireturn -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next + | Iifthenelse(_, ifso, ifnot) -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction ifso; + walk_instruction ifnot; + walk_instruction i.next + | Iswitch(_, cases) -> + insert_destroyed_at_oper intervals i !pos; + Array.iter walk_instruction cases; + walk_instruction i.next + | Iloop body -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction body; + walk_instruction i.next + | Icatch(_, body, handler) -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction body; + walk_instruction handler; + walk_instruction i.next + | Iexit _ -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction i.next + | Itrywith(body, handler) -> + insert_destroyed_at_oper intervals i !pos; + walk_instruction body; + insert_destroyed_at_raise intervals !pos; + walk_instruction handler; + walk_instruction i.next + | Iraise -> + walk_instruction i.next + end in + walk_instruction fd.fun_body; + (* Generate the interval and fixed interval lists *) + interval_list := []; + fixed_interval_list := []; + Array.iter + (fun i -> + if i.iend != 0 then begin + i.ranges <- List.rev i.ranges; + begin match i.reg.loc with + Reg _ -> + fixed_interval_list := i :: !fixed_interval_list + | _ -> + interval_list := i :: !interval_list + end + end) + intervals; + (* Sort the intervals according to their start position *) + interval_list := List.sort (fun i0 i1 -> i0.ibegin - i1.ibegin) !interval_list diff --git a/asmcomp/interval.mli b/asmcomp/interval.mli new file mode 100644 index 0000000..af4538d --- /dev/null +++ b/asmcomp/interval.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Live intervals for the linear scan register allocator. *) + +type range = + { + mutable rbegin: int; + mutable rend: int; + } + +type t = + { + mutable reg: Reg.t; + mutable ibegin: int; + mutable iend: int; + mutable ranges: range list; + } + +val all_intervals: unit -> t list +val all_fixed_intervals: unit -> t list +val overlap: t -> t -> bool +val is_live: t -> int -> bool +val remove_expired_ranges: t -> int -> unit +val build_intervals: Mach.fundecl -> unit diff --git a/asmcomp/linscan.ml b/asmcomp/linscan.ml new file mode 100644 index 0000000..01777ef --- /dev/null +++ b/asmcomp/linscan.ml @@ -0,0 +1,194 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Linear scan register allocation. *) + +open Interval +open Clflags +open List +open Format +open Mach +open Reg + +(* Live intervals per register class *) + +type class_intervals = + { + mutable ci_fixed: Interval.t list; + mutable ci_active: Interval.t list; + mutable ci_inactive: Interval.t list; + } + +let active = Array.init Proc.num_register_classes (fun _ -> { + ci_fixed = []; + ci_active = []; + ci_inactive = [] +}) + +(* Insert interval into list sorted by end position *) + +let rec insert_interval_sorted i = function + [] -> [i] + | j :: _ as il when j.iend <= i.iend -> i :: il + | j :: il -> j :: insert_interval_sorted i il + +let rec release_expired_fixed pos = function + i :: il when i.iend >= pos -> + Interval.remove_expired_ranges i pos; + i :: release_expired_fixed pos il + | _ -> [] + +let rec release_expired_active ci pos = function + i :: il when i.iend >= pos -> + Interval.remove_expired_ranges i pos; + if Interval.is_live i pos then + i :: release_expired_active ci pos il + else begin + ci.ci_inactive <- insert_interval_sorted i ci.ci_inactive; + release_expired_active ci pos il + end + | _ -> [] + +let rec release_expired_inactive ci pos = function + i :: il when i.iend >= pos -> + Interval.remove_expired_ranges i pos; + if not (Interval.is_live i pos) then + i :: release_expired_inactive ci pos il + else begin + ci.ci_active <- insert_interval_sorted i ci.ci_active; + release_expired_inactive ci pos il + end + | _ -> [] + +(* Allocate a new stack slot to the interval. *) + +let allocate_stack_slot i = + let cl = Proc.register_class i.reg in + let ss = Proc.num_stack_slots.(cl) in + Proc.num_stack_slots.(cl) <- succ ss; + i.reg.loc <- Stack(Local ss); + i.reg.spill <- true + +(* Find a register for the given interval and assigns this register. + The interval is added to active. Raises Not_found if no free registers + left. *) + +let allocate_free_register i = + begin match i.reg.loc, i.reg.spill with + Unknown, true -> + (* Allocate a stack slot for the already spilled interval *) + allocate_stack_slot i + | Unknown, _ -> + (* We need to allocate a register to this interval somehow *) + let cl = Proc.register_class i.reg in + begin match Proc.num_available_registers.(cl) with + 0 -> + (* There are no registers available for this class *) + raise Not_found + | rn -> + let ci = active.(cl) in + let r0 = Proc.first_available_register.(cl) in + (* Create register mask for this class *) + let regmask = Array.make rn true in + (* Remove all assigned registers from the register mask *) + List.iter + (function + {reg = {loc = Reg r}} -> regmask.(r - r0) <- false + | _ -> ()) + ci.ci_active; + (* Remove all overlapping registers from the register mask *) + let remove_bound_overlapping = function + {reg = {loc = Reg r}} as j -> + if regmask.(r - r0) && Interval.overlap j i then + regmask.(r - r0) <- false + | _ -> () in + List.iter remove_bound_overlapping ci.ci_inactive; + List.iter remove_bound_overlapping ci.ci_fixed; + (* Assign the first free register (if any) *) + let rec assign r = + if r = rn then + raise Not_found + else if regmask.(r) then begin + (* Assign the free register and insert the + current interval into the active list *) + i.reg.loc <- Reg (r0 + r); + i.reg.spill <- false; + ci.ci_active <- insert_interval_sorted i ci.ci_active + end else + assign (succ r) in + assign 0 + end + | _ -> () + end + +let allocate_blocked_register i = + let cl = Proc.register_class i.reg in + let ci = active.(cl) in + begin match ci.ci_active with + ilast :: il when ilast.iend > i.iend -> + (* Last interval in active is the last interval, so spill it. *) + begin match ilast.reg.loc with + Reg _ as loc -> + (* Use register from last interval for current interval *) + i.reg.loc <- loc + | _ -> () + end; + (* Remove the last interval from active and insert the current *) + ci.ci_active <- insert_interval_sorted i il; + (* Now get a new stack slot for the spilled register *) + allocate_stack_slot ilast + | _ -> + (* Either the current interval is last and we have to spill it, + or there are no registers at all in the register class (i.e. + floating point class on i386). *) + allocate_stack_slot i + end + +let walk_interval i = + let pos = i.ibegin land (lnot 0x01) in + (* Release all intervals that have been expired at the current position *) + Array.iter + (fun ci -> + ci.ci_fixed <- release_expired_fixed pos ci.ci_fixed; + ci.ci_active <- release_expired_active ci pos ci.ci_active; + ci.ci_inactive <- release_expired_inactive ci pos ci.ci_inactive) + active; + try + (* Allocate free register (if any) *) + allocate_free_register i + with + Not_found -> + (* No free register, need to decide which interval to spill *) + allocate_blocked_register i + +let allocate_registers() = + (* Initialize the stack slots and interval lists *) + for cl = 0 to Proc.num_register_classes - 1 do + (* Start with empty interval lists *) + active.(cl) <- { + ci_fixed = []; + ci_active = []; + ci_inactive = [] + }; + Proc.num_stack_slots.(cl) <- 0 + done; + (* Add all fixed intervals (sorted by end position) *) + List.iter + (fun i -> + let ci = active.(Proc.register_class i.reg) in + ci.ci_fixed <- insert_interval_sorted i ci.ci_fixed) + (Interval.all_fixed_intervals()); + (* Walk all the intervals within the list *) + List.iter walk_interval (Interval.all_intervals()) diff --git a/asmcomp/linscan.mli b/asmcomp/linscan.mli new file mode 100644 index 0000000..4cee154c --- /dev/null +++ b/asmcomp/linscan.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Marcell Fischbach, University of Siegen *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse, *) +(* Universität Siegen. All rights reserved. This file is distri- *) +(* buted under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Linear scan register allocation. *) + +val allocate_registers: unit -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index d7d538d..3f02956 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -18,6 +18,7 @@ open Format open Cmm open Reg open Mach +open Interval let reg ppf r = if String.length r.name > 0 then @@ -207,6 +208,18 @@ let interferences ppf () = fprintf ppf "*** Interferences@."; List.iter (interference ppf) (Reg.all_registers()) +let interval ppf i = + let interv ppf = + List.iter + (fun r -> fprintf ppf "@ [%d;%d]" r.rbegin r.rend) + i.ranges in + fprintf ppf "@[<2>%a:%t@]@." reg i.reg interv + +let intervals ppf () = + fprintf ppf "*** Intervals@."; + List.iter (interval ppf) (Interval.all_fixed_intervals()); + List.iter (interval ppf) (Interval.all_intervals()) + let preference ppf r = let prefs ppf = List.iter diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli index 2832870..43d4871 100644 --- a/asmcomp/printmach.mli +++ b/asmcomp/printmach.mli @@ -26,6 +26,7 @@ val instr: formatter -> Mach.instruction -> unit val fundecl: formatter -> Mach.fundecl -> unit val phase: string -> formatter -> Mach.fundecl -> unit val interferences: formatter -> unit -> unit +val intervals: formatter -> unit -> unit val preferences: formatter -> unit -> unit val print_live: bool ref diff --git a/driver/main_args.ml b/driver/main_args.ml index 279a463..7b60193 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -121,6 +121,10 @@ let mk_linkall f = "-linkall", Arg.Unit f, " Link all modules, even unused ones" ;; +let mk_linscan f = + "-linscan", Arg.Unit f, " Use the linear scan register allocator" +;; + let mk_make_runtime f = "-make-runtime", Arg.Unit f, " Build a runtime system with given C objects and libraries" @@ -362,6 +366,11 @@ let mk_dlinear f = "-dlinear", Arg.Unit f, " (undocumented)" ;; +let mk_dinterval f = + "-dinterval", Arg.Unit f, " (undocumented)" +;; + + let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; @@ -472,6 +481,7 @@ module type Optcomp_options = sig val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit @@ -515,6 +525,7 @@ module type Optcomp_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -526,6 +537,7 @@ module type Opttop_options = sig val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit @@ -557,6 +569,7 @@ module type Opttop_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -682,6 +695,7 @@ struct mk_intf_suffix F._intf_suffix; mk_labels F._labels; mk_linkall F._linkall; + mk_linscan F._linscan; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; @@ -718,12 +732,14 @@ struct mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; @@ -737,6 +753,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_init F._init; mk_inline F._inline; mk_labels F._labels; + mk_linscan F._linscan; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_nolabels F._nolabels; @@ -760,12 +777,14 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dspill; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; + mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk__ F.anonymous; diff --git a/driver/main_args.mli b/driver/main_args.mli index 1c4abf5..f441507 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -115,6 +115,7 @@ module type Optcomp_options = sig val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit @@ -158,6 +159,7 @@ module type Optcomp_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit @@ -169,6 +171,7 @@ module type Opttop_options = sig val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit + val _linscan : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit @@ -200,6 +203,7 @@ module type Opttop_options = sig val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit + val _dinterval : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 1c7352c..1db63d5 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -115,6 +115,7 @@ module Options = Main_args.Make_optcomp_options (struct let _intf_suffix s = Config.interface_suffix := s let _labels = clear classic let _linkall = set link_everything + let _linscan = set use_linscan let _no_app_funct = clear applicative_functors let _noassert = set noassert let _noautolink = set no_auto_link @@ -158,6 +159,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = anonymous diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index 583680d..d8d84b9 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -71,6 +71,7 @@ OTHEROBJS=\ $(TOPDIR)/asmcomp/compilenv.cmo \ $(TOPDIR)/asmcomp/closure.cmo \ $(TOPDIR)/asmcomp/cmmgen.cmo \ + $(TOPDIR)/asmcomp/interval.cmo \ $(TOPDIR)/asmcomp/printmach.cmo \ $(TOPDIR)/asmcomp/selectgen.cmo \ $(TOPDIR)/asmcomp/selection.cmo \ @@ -80,6 +81,7 @@ OTHEROBJS=\ $(TOPDIR)/asmcomp/split.cmo \ $(TOPDIR)/asmcomp/interf.cmo \ $(TOPDIR)/asmcomp/coloring.cmo \ + $(TOPDIR)/asmcomp/linscan.cmo \ $(TOPDIR)/asmcomp/reloadgen.cmo \ $(TOPDIR)/asmcomp/reload.cmo \ $(TOPDIR)/asmcomp/printlinear.cmo \ diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index bd27abb..f639d37 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -69,6 +69,7 @@ module Options = Main_args.Make_opttop_options (struct let _init s = init_file := Some s let _inline n = inline_threshold := n * 8 let _labels = clear classic + let _linscan = set use_linscan let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic @@ -100,6 +101,7 @@ module Options = Main_args.Make_opttop_options (struct let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear + let _dinterval = set dump_interval let _dstartup = set keep_startup_file let anonymous = file_argument diff --git a/utils/clflags.ml b/utils/clflags.ml index 1074d36..63d39a1 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -26,6 +26,7 @@ and print_types = ref false (* -i *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) and fast = ref false (* -unsafe *) +and use_linscan = ref false (* -linscan *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) @@ -73,6 +74,7 @@ let dump_regalloc = ref false (* -dalloc *) let dump_reload = ref false (* -dreload *) let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) +let dump_interval = ref false (* -dinterval *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) diff --git a/utils/clflags.mli b/utils/clflags.mli index d5357ef..0cbf8e3 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -23,6 +23,7 @@ val print_types : bool ref val make_archive : bool ref val debug : bool ref val fast : bool ref +val use_linscan : bool ref val link_everything : bool ref val custom_runtime : bool ref val output_c_object : bool ref @@ -67,6 +68,7 @@ val dump_regalloc : bool ref val dump_reload : bool ref val dump_scheduling : bool ref val dump_linear : bool ref +val dump_interval : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref

Notes
(0006073) frisch (developer) 2011-08-02 21:06	This patch is very interesting. Could you post here some timings (compilation speed and performance of compiled code)? Minor question about the patch: wouldn't it be cleaner to have a single function Asmgen.regalloc with a conditional on use_linscan, rather than having two functions called in sequence that do their job or nothing according to the situation? Also, is it really necessary to redefine sys_time? (As opposed to using Sys.time which is in the stdlib.)

(0006075) meurer (developer) 2011-08-03 10:20	I forwarded your questions. As said, it's the very first working patch, and there are no timing results yet.

(0006094) meurer (developer) 2011-08-18 19:13	I've imported the most recent patch from Marcell with some cleanups, merged the latest changes from the 3.12 branch and uploaded the project to GitHub at https://github.com/bmeurer/ocaml-experimental/tree/linear-scan-register-allocator [^] in the linear-scan-register-allocator branch (for reference). Marcell did some benchmarking and will publish the results soon.

(0006095) marcell (reporter) 2011-08-19 10:09	I've added timings for the runtime performance for amd64 and i386. Both showing the runtime for code compiled with the graph-coloring and the linear-scan algorithm and the ratio of the two measurements. Although meurer already merged the latest changed into the GitHub-Repository I also added the latest diff. I will add timings for the compilation time soon.

(0006103) marcell (reporter) 2011-08-24 20:50	Added timing results for the compilation time and also added the runtime results again as a more readable diagram.

(0006110) meurer (developer) 2011-09-03 18:03	I've updated the patch with several cleanups and uploaded a new diff.

(0006134) meurer (developer) 2011-09-29 15:48	Updated patch, with several cleanups and fixes for the ARM port.

(0006854) xleroy (administrator) 2012-01-31 09:03	Here is my analysis of this proposal. The "big" users of OCaml, esp. the members of the Caml consortium, push strongly towards improving the performance of ocamlopt-generated code, but don't really care about compilation times. Linear scan register allocation goes in a different direction: fast compilation times at the cost of slightly lower quality of the generated code. I would rather invest time and effort on replacing ocamlopt's Briggs-style graph coloring by George and Appel's IRC graph coloring: this should result in slightly faster generated code and slightly lower compilation times at the same time. For the time being, let me just put this PR in the "suspended" state.

(0006855) meurer (developer) 2012-01-31 09:40	Ok, makes sense.

Issue History
Date Modified	Username	Field	Change
2011-08-01 17:01	meurer	New Issue
2011-08-01 17:01	meurer	File Added: ocaml-linear-scan-20110801.diff
2011-08-02 21:06	frisch	Note Added: 0006073
2011-08-03 10:20	meurer	Note Added: 0006075
2011-08-18 19:13	meurer	Note Added: 0006094
2011-08-19 09:48	marcell	File Added: timings_runtime_amd64.txt
2011-08-19 09:48	marcell	File Added: timings_runtime_i386.txt
2011-08-19 10:03	marcell	File Added: ocaml-linear-scan-20110819.diff
2011-08-19 10:09	marcell	Note Added: 0006095
2011-08-24 20:45	marcell	File Added: compiletime_timings.pdf
2011-08-24 20:45	marcell	File Added: runtime_timings.pdf
2011-08-24 20:50	marcell	Note Added: 0006103
2011-09-03 18:02	meurer	File Added: ocaml-linear-scan-20110903.diff
2011-09-03 18:03	meurer	Note Added: 0006110
2011-09-29 15:47	meurer	File Added: ocaml-linear-scan20110929.diff
2011-09-29 15:48	meurer	Note Added: 0006134
2011-10-14 11:09	meurer	File Added: ocaml-linear-scan-20111014.diff
2012-01-31 09:03	xleroy	Note Added: 0006854
2012-01-31 09:03	xleroy	Status	new => resolved
2012-01-31 09:03	xleroy	Resolution	open => suspended
2012-01-31 09:40	meurer	Note Added: 0006855

Relationships