reg.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Cmm

type irc_work_list =
  | Unknown_list
  | Precolored
  | Initial
  | Simplify
  | Freeze
  | Spill
  | Spilled
  | Coalesced
  | Colored
  | Select_stack

let string_of_irc_work_list = function
  | Unknown_list -> "unknown_list"
  | Precolored -> "precolored"
  | Initial -> "initial"
  | Simplify -> "simplify"
  | Freeze -> "freeze"
  | Spill -> "spill"
  | Spilled -> "spilled"
  | Coalesced -> "coalesced"
  | Colored -> "colored"
  | Select_stack -> "select_stack"

module V = Backend_var

module Raw_name = struct
  type t =
    | Anon
    | R
    | Var of V.t

  let create_from_var var = Var var

  let to_string t =
    match t with
    | Anon -> None
    | R -> Some "R"
    | Var var ->
      let name = V.name var in
      if String.length name <= 0 then None else Some name
end

type t =
  { mutable raw_name: Raw_name.t;
    stamp: int;
    typ: Cmm.machtype_component;
    mutable loc: location;
    mutable irc_work_list: irc_work_list;
    mutable irc_color : int option;
    mutable irc_alias : t option;
    mutable spill: bool;
    mutable part: int option;
    mutable interf: t list;
    mutable prefer: (t * int) list;
    mutable degree: int;
    mutable spill_cost: int;
    mutable visited: int }

and location =
    Unknown
  | Reg of int
  | Stack of stack_location

and stack_location =
    Local of int
  | Incoming of int
  | Outgoing of int
  | Domainstate of int

type reg = t

let dummy =
  { raw_name = Raw_name.Anon; stamp = 0; typ = Int; loc = Unknown;
    irc_work_list = Unknown_list; irc_color = None; irc_alias = None;
    spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0;
    visited = 0; part = None;
  }

let currstamp = ref 0
let reg_list = ref([] : t list)
let hw_reg_list = ref ([] : t list)

let visit_generation = ref 1

(* Any visited value not equal to !visit_generation counts as "unvisited" *)
let unvisited = 0

let mark_visited r =
  r.visited <- !visit_generation

let is_visited r =
  r.visited = !visit_generation

let clear_visited_marks () =
  incr visit_generation


let create ty =
  let r = { raw_name = Raw_name.Anon; stamp = !currstamp; typ = ty;
            loc = Unknown;
            irc_work_list = Unknown_list; irc_color = None; irc_alias = None;
            spill = false; interf = []; prefer = []; degree = 0;
            spill_cost = 0; visited = unvisited; part = None; } in
  reg_list := r :: !reg_list;
  incr currstamp;
  r

let createv tyv =
  let n = Array.length tyv in
  let rv = Array.make n dummy in
  for i = 0 to n-1 do rv.(i) <- create tyv.(i) done;
  rv

let createv_like rv =
  let n = Array.length rv in
  let rv' = Array.make n dummy in
  for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done;
  rv'

let clone r =
  let nr = create r.typ in
  nr.raw_name <- r.raw_name;
  nr

let at_location ty loc =
  let r = { raw_name = Raw_name.R; stamp = !currstamp; typ = ty; loc;
            irc_work_list = Unknown_list; irc_color = None; irc_alias = None;
            spill = false; interf = []; prefer = []; degree = 0;
            spill_cost = 0; visited = unvisited; part = None; } in
  hw_reg_list := r :: !hw_reg_list;
  incr currstamp;
  r

let typv rv =
  Array.map (fun r -> r.typ) rv

let anonymous t =
  match Raw_name.to_string t.raw_name with
  | None -> true
  | Some _raw_name -> false

let is_preassigned t =
  match t.raw_name with
  | R -> true
  | Anon | Var _ -> false

let is_unknown t =
  match t.loc with
  | Unknown -> true
  | Reg _ | Stack (Local _ | Incoming _ | Outgoing _ | Domainstate _) -> false

let name t =
  match Raw_name.to_string t.raw_name with
  | None -> ""
  | Some raw_name ->
    let with_spilled =
      if t.spill then
        "spilled-" ^ raw_name
      else
        raw_name
    in
    match t.part with
    | None -> with_spilled
    | Some part -> with_spilled ^ "#" ^ Int.to_string part

let first_virtual_reg_stamp = ref (-1)

let is_stack t =
  match t.loc with
  | Stack _ -> true
  | _ -> false

let is_reg t =
  match t.loc with
  | Reg _ -> true
  | _ -> false

let size_of_contents_in_bytes t =
  match t.typ with
  | Vec128 -> Arch.size_vec128
  | Float -> Arch.size_float
  | Float32 ->
    assert (Arch.size_float = 8);
    Arch.size_float / 2
  | Addr ->
    assert (Arch.size_addr = Arch.size_int);
    Arch.size_addr
  | Int | Val -> Arch.size_int

let reset() =
  (* When reset() is called for the first time, the current stamp reflects
     all hard pseudo-registers that have been allocated by Proc, so
     remember it and use it as the base stamp for allocating
     soft pseudo-registers *)
  if !first_virtual_reg_stamp = -1 then begin
    first_virtual_reg_stamp := !currstamp;
    assert (!reg_list = []) (* Only hard regs created before now *)
  end;
  currstamp := !first_virtual_reg_stamp;
  reg_list := [];
  visit_generation := 1;
  !hw_reg_list |> List.iter (fun r ->
    r.visited <- unvisited)

let all_registers() = !reg_list
let num_registers() = !currstamp

let reinit_reg r =
  r.loc <- Unknown;
  r.irc_work_list <- Unknown_list;
  r.irc_color <- None;
  r.irc_alias <- None;
  r.interf <- [];
  r.prefer <- [];
  r.degree <- 0;
  (* Preserve the very high spill costs introduced by the reloading pass *)
  if r.spill_cost >= 100000
  then r.spill_cost <- 100000
  else r.spill_cost <- 0

let reinit() =
  List.iter reinit_reg !reg_list

module RegOrder =
  struct
    type t = reg
    let compare r1 r2 = r1.stamp - r2.stamp
  end

module Set = Set.Make(RegOrder)
module Map = Map.Make(RegOrder)
module Tbl = Hashtbl.Make (struct
    type t = reg
    let equal r1 r2 = r1.stamp = r2.stamp
    let hash r = r.stamp
  end)

let add_set_array s v =
  match Array.length v with
    0 -> s
  | 1 -> Set.add v.(0) s
  | n -> let rec add_all i =
           if i >= n then s else Set.add v.(i) (add_all(i+1))
         in add_all 0

let diff_set_array s v =
  match Array.length v with
    0 -> s
  | 1 -> Set.remove v.(0) s
  | n -> let rec remove_all i =
           if i >= n then s else Set.remove v.(i) (remove_all(i+1))
         in remove_all 0

let inter_set_array s v =
  match Array.length v with
    0 -> Set.empty
  | 1 -> if Set.mem v.(0) s
         then Set.add v.(0) Set.empty
         else Set.empty
  | n -> let rec inter_all i =
           if i >= n then Set.empty
           else if Set.mem v.(i) s then Set.add v.(i) (inter_all(i+1))
           else inter_all(i+1)
         in inter_all 0

let disjoint_set_array s v =
  match Array.length v with
    0 -> true
  | 1 -> not (Set.mem v.(0) s)
  | n -> let rec disjoint_all i =
           if i >= n then true
           else if Set.mem v.(i) s then false
           else disjoint_all (i+1)
         in disjoint_all 0

let set_of_array v =
  match Array.length v with
    0 -> Set.empty
  | 1 -> Set.add v.(0) Set.empty
  | n -> let rec add_all i =
           if i >= n then Set.empty else Set.add v.(i) (add_all(i+1))
         in add_all 0

let set_has_collisions s =
  let phys_regs = Hashtbl.create (Int.min (Set.cardinal s) 32) in
  Set.fold (fun r acc ->
    match r.loc with
    | Reg id ->
      if Hashtbl.mem phys_regs id then true
      else (Hashtbl.add phys_regs id (); acc)
    | Unknown | Stack _ -> acc) s false

let equal_stack_location left right =
  match left, right with
  | Local left, Local right -> Int.equal left right
  | Incoming left, Incoming right -> Int.equal left right
  | Outgoing left, Outgoing right -> Int.equal left right
  | Domainstate left, Domainstate right -> Int.equal left right
  | Local _, (Incoming _ | Outgoing _ | Domainstate _)
  | Incoming _, (Local _ | Outgoing _ | Domainstate _)
  | Outgoing _, (Local _ | Incoming _ | Domainstate _)
  | Domainstate _, (Local _ | Incoming _ | Outgoing _)->
    false

let equal_location left right =
  match left, right with
  | Unknown, Unknown -> true
  | Reg left, Reg right -> Int.equal left right
  | Stack left, Stack right -> equal_stack_location left right
  | Unknown, (Reg _ | Stack _)
  | Reg _, (Unknown | Stack _)
  | Stack _, (Unknown | Reg _) ->
    false

let same_phys_reg left right =
  match left.loc, right.loc with
  | Reg l, Reg r -> Int.equal l r
  | (Reg _ | Unknown | Stack _), _ -> false

let same_loc left right =
  (* CR-soon azewierzejew: This should also compare [reg_class] for [Stack
     (Local _)]. That's complicated because [reg_class] is definied in [Proc]
     which relies on [Reg]. *)
  equal_location left.loc right.loc

let same left right =
  Int.equal left.stamp right.stamp

let compare left right =
  Int.compare left.stamp right.stamp

(* Two registers have compatible types if we allow moves between them.
   Note that we never allow moves between different register classes, so this
   condition must be at least as strict as [class left = class right]. *)
let types_are_compatible left right =
  match left.typ, right.typ with
  | (Int | Val | Addr), (Int | Val | Addr)
  | Float, Float
  | Float32, Float32
  | Vec128, Vec128 ->
    true
  | (Int | Val | Addr | Float | Float32 | Vec128), _ -> false