chapter 20a: register allocation without coalescing

bin/main.ml

@@ -184,6 +184,14 @@ let debug =
     in
     Arg.(value & flag & info [ "dump-unreachable-elim" ] ~doc)
   in
+  let dump_gp_regalloc_opt =
+    let doc = "Verbosity level when allocating general-purpose registers" in
+    Arg.(value & opt ~vopt:1 int 0 & info [ "dump-gp-regalloc" ] ~doc)
+  in
+  let dump_xmm_regalloc_opt =
+    let doc = "Verbosity level when allocating XMM registers" in
+    Arg.(value & opt ~vopt:1 int 0 & info [ "dump-xmm-regalloc" ] ~doc)
+  in
   let dump_fun_opt =
     let doc =
       "Function to dump extra optimization details for (if not specified, dump \
@@ -194,7 +202,16 @@ let debug =
   in
   let set_debug_options dump_asm dump_tacky constant_folding
       dead_store_elimination copy_propagation unreachable_code_elimination
-      dump_fun =
+      dump_gp_regalloc_lvl dump_xmm_regalloc_lvl dump_fun =
+    let mk_regalloc_opts dump_lvl =
+      Settings.
+        {
+          spill_info = dump_lvl >= 1;
+          interference_ncol = dump_lvl >= 2;
+          interference_graphviz = dump_lvl >= 3;
+          liveness = dump_lvl >= 4;
+        }
+    in
     Settings.
       {
         dump_asm;
@@ -206,6 +223,8 @@ let debug =
             unreachable_code_elimination;
             copy_propagation;
           };
+        dump_gp_regalloc = mk_regalloc_opts dump_gp_regalloc_lvl;
+        dump_xmm_regalloc = mk_regalloc_opts dump_xmm_regalloc_lvl;
         dump_fun;
       }
   in
@@ -217,6 +236,8 @@ let debug =
     $ dump_dse_opt
     $ dump_copy_prop_opt
     $ dump_unreachable_elim_opt
+    $ dump_gp_regalloc_opt
+    $ dump_xmm_regalloc_opt
     $ dump_fun_opt)
 
 let src_file =

lib/assembly.ml

@@ -1,5 +1,8 @@
+[@@@coverage exclude_file]
+
 type reg =
   | AX
+  | BX
   | CX
   | DX
   | DI
@@ -8,6 +11,10 @@ type reg =
   | R9
   | R10
   | R11
+  | R12
+  | R13
+  | R14
+  | R15
   | SP
   | BP
   | XMM0
@@ -18,8 +25,15 @@ type reg =
   | XMM5
   | XMM6
   | XMM7
+  | XMM8
+  | XMM9
+  | XMM10
+  | XMM11
+  | XMM12
+  | XMM13
   | XMM14
   | XMM15
+[@@deriving show { with_path = false }]
 
 type operand =
   | Imm of int64
@@ -29,8 +43,10 @@ type operand =
   | Data of string * int
   | PseudoMem of string * int
   | Indexed of { base : reg; index : reg; scale : int }
+[@@deriving show { with_path = false }]
 
 type unary_operator = Neg | Not | ShrOneOp
+[@@deriving show { with_path = false }]
 
 type binary_operator =
   | Add
@@ -44,15 +60,18 @@ type binary_operator =
   | Sar
   | Shr
   | Shl
+[@@deriving show { with_path = false }]
 
 type cond_code = E | NE | G | GE | L | LE | A | AE | B | BE | P | NP
+[@@deriving show { with_path = false }]
 
 type asm_type =
   | Byte
   | Longword
   | Quadword
   | Double
   | ByteArray of { size : int; alignment : int }
+[@@deriving show { with_path = false }]
 
 type instruction =
   | Mov of asm_type * operand * operand
@@ -87,8 +106,10 @@ type instruction =
   | SetCC of cond_code * operand
   | Label of string
   | Push of operand
+  | Pop of reg
   | Call of string
   | Ret
+[@@deriving show { with_path = false }]
 
 type top_level =
   | Function of {

lib/backend/assembly_symbols.ml

@@ -1,14 +1,29 @@
 open Batteries
 
 type entry =
-  | Fun of { defined : bool; bytes_required : int; return_on_stack : bool }
+  | Fun of {
+      defined : bool;
+      bytes_required : int;
+      return_on_stack : bool;
+      param_regs : Assembly.reg list;
+      return_regs : Assembly.reg list;
+      callee_saved_regs_used : Assembly.reg Set.t;
+    }
   | Obj of { t : Assembly.asm_type; is_static : bool; constant : bool }
 
 let (symbol_table : (string, entry) Hashtbl.t) = Hashtbl.create 20
 
-let add_fun fun_name defined return_on_stack =
+let add_fun fun_name defined return_on_stack param_regs return_regs =
   Hashtbl.replace symbol_table fun_name
-    (Fun { defined; bytes_required = 0; return_on_stack })
+    (Fun
+       {
+         defined;
+         bytes_required = 0;
+         callee_saved_regs_used = Set.empty;
+         return_on_stack;
+         param_regs;
+         return_regs;
+       })
 
 let add_var var_name t is_static =
   Hashtbl.replace symbol_table var_name (Obj { t; is_static; constant = false })
@@ -29,6 +44,24 @@ let get_bytes_required fun_name =
   | Fun f -> f.bytes_required
   | Obj _ -> failwith "Internal error: not a function" [@coverage off]
 
+let add_callee_saved_regs_used fun_name regs =
+  let set_regs = function
+    | Fun f ->
+        Fun
+          {
+            f with
+            callee_saved_regs_used = Set.union f.callee_saved_regs_used regs;
+          }
+    | Obj _ -> failwith "Internal error: not a function" [@coverage off]
+  in
+
+  Hashtbl.modify fun_name set_regs symbol_table
+
+let get_callee_saved_regs_used fun_name =
+  match Hashtbl.find symbol_table fun_name with
+  | Fun f -> f.callee_saved_regs_used
+  | Obj _ -> failwith "Internal error: not a function" [@coverage off]
+
 let get_size var_name =
   match Hashtbl.find symbol_table var_name with
   | Obj { t = Byte; _ } -> 1
@@ -82,3 +115,13 @@ let returns_on_stack fun_name =
   | Obj _ ->
       failwith "Internal error: this is an object, not a function"
       [@coverage off]
+
+let param_regs_used fun_name =
+  match Hashtbl.find symbol_table fun_name with
+  | Fun f -> f.param_regs
+  | Obj _ -> failwith "Internal error: not a function" [@coverage off]
+
+let return_regs_used fun_name =
+  match Hashtbl.find symbol_table fun_name with
+  | Fun f -> f.return_regs
+  | Obj _ -> failwith "Internal error: not a function" [@coverage off]

lib/backend/assembly_symbols.mli

@@ -1,12 +1,18 @@
-val add_fun : string -> bool -> bool -> unit
+val add_fun :
+  string -> bool -> bool -> Assembly.reg list -> Assembly.reg list -> unit
+
 val add_var : string -> Assembly.asm_type -> bool -> unit
 val add_constant : string -> Assembly.asm_type -> unit
 val set_bytes_required : string -> int -> unit
 val get_bytes_required : string -> int
+val add_callee_saved_regs_used : string -> Assembly.reg Batteries.Set.t -> unit
+val get_callee_saved_regs_used : string -> Assembly.reg Batteries.Set.t
 val get_type : string -> Assembly.asm_type
 val get_size : string -> int
 val get_alignment : string -> int
 val is_defined : string -> bool
 val is_constant : string -> bool
 val is_static : string -> bool
 val returns_on_stack : string -> bool
+val param_regs_used : string -> Assembly.reg list
+val return_regs_used : string -> Assembly.reg list