From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from mail4-relais-sop.national.inria.fr (mail4-relais-sop.national.inria.fr [192.134.164.105]) by walapai.inria.fr (8.13.6/8.13.6) with ESMTP id p71EsJnP030462 for ; Mon, 1 Aug 2011 16:54:19 +0200 X-IronPort-Anti-Spam-Filtered: true X-IronPort-Anti-Spam-Result: AuYEAN29Nk7RVdc2kGdsb2JhbABBmFGNEYF3CBQBAQEBCQkNBxQEIYFZAiwBATcBTkYBBQFXh0wComUKjwMBjgMFhWNfn0s8g14 X-IronPort-AV: E=Sophos;i="4.67,300,1309730400"; d="diff'?scan'208";a="104436255" Received: from mail-ew0-f54.google.com ([209.85.215.54]) by mail4-smtp-sop.national.inria.fr with ESMTP/TLS/RC4-SHA; 01 Aug 2011 16:53:57 +0200 Received: by ewy1 with SMTP id 1so6780813ewy.27 for ; Mon, 01 Aug 2011 07:53:56 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=googlemail.com; s=gamma; h=from:content-type:subject:date:message-id:cc:to:mime-version :x-mailer; bh=I8fhPzXOA/osOoVwzf64M0RT7HkcufX/c9kIyZsXo2s=; b=EqfdbIjaEhqAaX6dKZH03QqxjtiDvN5PXHjEasZ5j3jsIotVFqE/a1yzkDiEMS+WaE d/aNGfmnR6f0cBx/Bc+7WN5RFZ2fuGk5cliIqK6eCmms7FP7H8pxrfq8isZqPh7wssRt cWWx6obG5M8rwuhqc0rQ6QEgAk/pPBlC4FqLw= Received: by 10.204.19.193 with SMTP id c1mr1364616bkb.324.1312210436688; Mon, 01 Aug 2011 07:53:56 -0700 (PDT) Received: from coruscant.kosmos.all (ip-95-223-170-32.unitymediagroup.de [95.223.170.32]) by mx.google.com with ESMTPS id q1sm1442089faa.3.2011.08.01.07.53.52 (version=SSLv3 cipher=OTHER); Mon, 01 Aug 2011 07:53:53 -0700 (PDT) From: Benedikt Meurer Content-Type: multipart/mixed; boundary="Apple-Mail=_5A44EA65-6B4A-46B3-892C-AA09A5620660" Date: Mon, 1 Aug 2011 16:53:51 +0200 Message-Id: <93199F3B-E9CF-4D93-9B2B-BAAB03F4FC08@googlemail.com> Cc: Marcell Fischbach To: caml-list@inria.fr Mime-Version: 1.0 (Apple Message framework v1244.3) X-Mailer: Apple Mail (2.1244.3) Subject: [Caml-list] Linear Scan Register Allocator for ocamlopt/ocamlnat --Apple-Mail=_5A44EA65-6B4A-46B3-892C-AA09A5620660 Content-Transfer-Encoding: quoted-printable Content-Type: text/plain; charset=us-ascii Hello, As mentioned earlier we have a student working on an implementation of the = Linear Scan Register Allocator [1] for ocamlopt (and thereby ocamlnat). It = took some time, but now there's a first working patch which looks promising= . This work is done by Marcell Fischbach as part of his diploma thesis. The= idea is to use the linear scan algorithm to drive the register allocation = in the native top-level ocamlnat at some point, as suggested by Fabrice Le = Fessant [2]. Marcell is now working to implement a proof-of-concept of an inline assembl= er for ocamlnat on i386 based on code from Alain Frisch an Fabrice Le Fessa= nt. The result will also be contributed once ready, and will be used to eff= ectively compare ocamlnat and the byte-code ocaml top-level. The linear scan implementation reuses as much of the existing ocamlopt func= tionality as possible, so additional maintenance overhead should be managea= ble. Comments and suggestions are welcome of course. Please keep Marcell CC= 'ed with any replies as he's not subscribed to the list. greets, Benedikt [1] http://portal.acm.org/citation.cfm?id=3D330250 [2] http://caml.inria.fr/pub/ml-archives/caml-list/2010/11/a1b0ed0934ff51df= 4ac07c5e9da6e9d6.en.html --Apple-Mail=_5A44EA65-6B4A-46B3-892C-AA09A5620660 Content-Disposition: attachment; filename=ocaml-linear-scan-20110801.diff Content-Type: application/octet-stream; x-unix-mode=0644; name="ocaml-linear-scan-20110801.diff" Content-Transfer-Encoding: 7bit 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, " (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 --Apple-Mail=_5A44EA65-6B4A-46B3-892C-AA09A5620660--