Merge branch 'sus' into regalloc

README.md

@@ -48,9 +48,9 @@ Written by: Utku Melemeti, Ethan Uppal, Jeffrey Huang, Jason Klein, Vijay Shanmu
     - Abstract syntax tree
     - Type checking
 
-With some contributions from
-- Vijay Shanmugam (vrs29)
+With minor contributions from
 - Jason Klein (jak532)
+- Vijay Shanmugam (vrs29)
 
 ## Usage
 

README.md.template

@@ -31,9 +31,9 @@ $ ./main -v
     - Abstract syntax tree
     - Type checking
 
-With some contributions from
-- Vijay Shanmugam (vrs29)
+With minor contributions from
 - Jason Klein (jak532)
+- Vijay Shanmugam (vrs29)
 
 ## Usage
 

lib/backend/asm.ml

@@ -131,6 +131,7 @@ module Section : sig
   (** [add section instr] adds [instr] to the end of [section]. *)
   val add : t -> Instruction.t -> unit
 
+  val add_all : t -> Instruction.t list -> unit
   val to_nasm : t -> string
 end = struct
   type t = {
@@ -141,6 +142,7 @@ end = struct
 
   let make name align = { name; align; contents = BatDynArray.make 16 }
   let add section = BatDynArray.add section.contents
+  let add_all section instrs = List.iter (add section) instrs
 
   let to_nasm section =
     ("section ." ^ section.name)

lib/backend/asm_emit.ml

@@ -1,12 +1,71 @@
-let emit_ir section =
-  ignore section;
-  failwith "i hate reg alloc"
-
-let emit_bb section cfg bb =
-  let ir = Basic_block.to_list bb in
-  let jumps = Cfg.out_edges cfg bb in
-  ignore jumps;
-  List.iter (emit_ir section) ir;
-  failwith "emit jumps"
-
-let emit section cfg = Cfg.blocks_of cfg |> List.iter (emit_bb section cfg)
+let emit_var regalloc var =
+  Asm.Operand.Register (Ir.VariableMap.find regalloc var)
+
+let emit_oper regalloc = function
+  | Operand.Variable var -> emit_var regalloc var
+  | Constant int -> Asm.Operand.Intermediate int
+
+let emit_call text regalloc name args =
+  Asm.Section.add_all text
+    [
+      Push (Register RDI);
+      Push (Register RDI);
+      (* double push for 16 byte alignment *)
+      Mov (Register RDI, List.hd args |> emit_oper regalloc);
+      Call (Label name);
+      Pop (Register RDI);
+      Pop (Register RDI);
+    ]
+
+(** *)
+let emit_ir text regalloc = function
+  | Ir.Assign (var, op) ->
+      Asm.Section.add text (Mov (emit_var regalloc var, emit_oper regalloc op))
+  | Add (var, op, op2) ->
+      Asm.Section.add_all text
+        [
+          Mov (emit_var regalloc var, emit_oper regalloc op);
+          Add (emit_var regalloc var, emit_oper regalloc op2);
+        ]
+  | Sub (var, op, op2) | TestEqual (var, op, op2) ->
+      Asm.Section.add_all text
+        [
+          Mov (emit_var regalloc var, emit_oper regalloc op);
+          Sub (emit_var regalloc var, emit_oper regalloc op2);
+        ]
+  | Ref _ -> failwith "ref not impl"
+  | Deref _ -> failwith "deref not impl"
+  | DebugPrint op -> emit_call text regalloc "_x86istimb_debug_print" [ op ]
+  | Call _ -> failwith "TODO"
+  | Return op ->
+      Asm.Section.add text (Mov (Register RAX, emit_oper regalloc op))
+
+let emit_bb text cfg regalloc bb =
+  Asm.Section.add text
+    (Label
+       (Asm.Label.make ~is_global:false ~is_external:false
+          (Basic_block.label_for bb)));
+  bb |> Basic_block.to_list |> List.iter (emit_ir text regalloc);
+  match Basic_block.condition_of bb with
+  | Never | Conditional (Constant 0) -> ()
+  | Always | Conditional (Constant _) ->
+      let dest_bb = Cfg.take_branch cfg bb true |> Option.get in
+      Asm.Section.add text (Jmp (Label (Basic_block.label_for dest_bb)))
+  | Conditional op -> (
+      let true_bb = Cfg.take_branch cfg bb true |> Option.get in
+      let false_bb = Cfg.take_branch cfg bb false |> Option.get in
+      match op with
+      | Variable var ->
+          Asm.Section.add text (Cmp (emit_var regalloc var, Intermediate 0));
+          Asm.Section.add text (Je (Label (Basic_block.label_for false_bb)));
+          Asm.Section.add text (Jmp (Label (Basic_block.label_for true_bb)))
+      | Constant _ -> failwith "failure")
+
+let emit_preamble ~text =
+  Asm.Section.add text
+    (Label
+       (Asm.Label.make ~is_global:false ~is_external:true
+          "_x86istimb_debug_print"))
+
+let emit_cfg ~text cfg regalloc =
+  Cfg.blocks_of cfg |> List.iter (emit_bb text cfg regalloc)

lib/backend/asm_emit.mli

@@ -1,3 +1,8 @@
-(** [emit section cfg] emits the function [cfg] into the assembly section
-    [section]. *)
-val emit : Asm.Section.t -> Cfg.t -> unit
+(** [emit_preamble ~text:text] emits the x86istmb runtime preamble into the
+    assembly code section [text]. *)
+val emit_preamble : text:Asm.Section.t -> unit
+
+(** [emit ~text:text cfg regalloc] emits the function [cfg] with register
+    allocation [regalloc] into the assembly code section [text]. *)
+val emit_cfg :
+  text:Asm.Section.t -> Cfg.t -> Regalloc.allocation Ir.VariableMap.t -> unit

lib/backend/regalloc/regalloc.ml

@@ -1,5 +1,4 @@
 open Util
-module VarTbl = Hashtbl.Make (Variable)
 
 (* TODO: standardize instruction id? *)
 type instr_id = Id.t * int
@@ -26,7 +25,7 @@ let registers =
 
 let live_intervals (cfg : Cfg.t) (liveliness : BBAnalysis.t IdMap.t)
     (ordering : InstrOrdering.t) =
-  let tbl = VarTbl.create 16 in
+  let tbl = Ir.VariableMap.create 16 in
 
   let expand_interval original live_id =
     let cmp = InstrOrdering.compare ordering in
@@ -38,13 +37,13 @@ let live_intervals (cfg : Cfg.t) (liveliness : BBAnalysis.t IdMap.t)
   let update_table instr_id used_set =
     Liveliness.VariableSet.iter
       (fun live ->
-        let current_opt = VarTbl.find_opt tbl live in
+        let current_opt = Ir.VariableMap.find_opt tbl live in
         let new_interval =
           match current_opt with
           | None -> { start = instr_id; stop = instr_id }
           | Some current -> expand_interval current instr_id
         in
-        VarTbl.replace tbl live new_interval)
+        Ir.VariableMap.replace tbl live new_interval)
       used_set
   in
 
@@ -64,7 +63,7 @@ let live_intervals (cfg : Cfg.t) (liveliness : BBAnalysis.t IdMap.t)
       done)
     cfg;
 
-  VarTbl.to_seq tbl |> List.of_seq
+  Ir.VariableMap.to_seq tbl |> List.of_seq
 
 (* Algorithm source:
    https://en.wikipedia.org/wiki/Register_allocation#Pseudocode *)
@@ -75,7 +74,7 @@ let linear_scan (intervals : (Variable.t * interval) list)
   let compare_pair_end (_, i1) (_, i2) = compare_instr_id i1.stop i2.stop in
   let sorted_intervals = List.sort compare_pair_start intervals in
 
-  let assigned_alloc : allocation VarTbl.t = VarTbl.create 4 in
+  let assigned_alloc : allocation Ir.VariableMap.t = Ir.VariableMap.create 4 in
 
   let module RegSet = Set.Make (Asm.Register) in
   let free_registers : RegSet.t ref = ref (RegSet.of_list registers) in
@@ -96,7 +95,7 @@ let linear_scan (intervals : (Variable.t * interval) list)
       (fun (var, interval) ->
         let keep = compare_instr_id interval.stop current.start >= 0 in
         (if not keep then
-           let alloc = VarTbl.find assigned_alloc var in
+           let alloc = Ir.VariableMap.find assigned_alloc var in
            match alloc with
            | Register r -> free_registers := RegSet.add r !free_registers
            | Spill _ -> failwith "Interval in active cannot be spilled");
@@ -133,7 +132,7 @@ let linear_scan (intervals : (Variable.t * interval) list)
       match RegSet.choose_opt !free_registers with
       | Some register ->
           free_registers := RegSet.remove register !free_registers;
-          VarTbl.replace assigned_alloc var (Register register);
+          Ir.VariableMap.replace assigned_alloc var (Register register);
           BatRefList.push active (var, interval);
           BatRefList.sort ~cmp:compare_pair_end active
       | None -> spill_at_interval (var, interval))

lib/backend/regalloc/regalloc.mli

@@ -1,5 +1,4 @@
 open Util
-module VarTbl : Hashtbl.S with type key = Variable.t
 
 type allocation =
   | Register of Asm.Register.t
@@ -11,4 +10,4 @@ val allocate_for :
   Cfg.t ->
   Liveliness.BasicBlockAnalysis.t IdMap.t ->
   InstrOrdering.t ->
-  allocation VarTbl.t
+  allocation Ir.VariableMap.t

lib/core/util.ml

@@ -68,17 +68,3 @@ let basename =
 let pp_of string_of fmt x = Format.fprintf fmt "%s" (string_of x)
 
 module IdMap = Hashtbl.Make (Id)
-
-module ArrayView : sig
-  type 'a t
-
-  val from_bat_dyn_arr : 'a BatDynArray.t -> 'a t
-  val length : 'a t -> int
-  val get : 'a t -> int -> 'a
-  val last : 'a t -> 'a
-  val iteri : (int -> 'a -> unit) -> 'a t -> unit
-end = struct
-  let from_bat_dyn_arr = id
-
-  include BatDynArray
-end

lib/ir/basic_block.ml

@@ -29,11 +29,12 @@ let get_orig_idx bb idx = BatDynArray.get bb.contents idx |> snd
 let set_ir bb idx ir = BatDynArray.set bb.contents idx (ir, get_orig_idx bb idx)
 let rem_ir bb idx = BatDynArray.remove_at idx bb.contents
 let to_list bb = BatDynArray.to_list bb.contents |> List.map fst
+let label_for bb = Printf.sprintf ".L_BB%d:" (id_of bb |> Id.int_of)
 let equal bb1 bb2 = Id.equal bb1.id bb2.id
 let hash bb = Id.int_of bb.id |> Int.hash
 
 let to_string bb =
-  Printf.sprintf ".L%d:" (id_of bb |> Id.int_of)
+  label_for bb
   ^ BatDynArray.fold_left
       (fun acc (ir, _) -> acc ^ "\n  " ^ Ir.to_string ir)
       "" bb.contents

lib/ir/basic_block.mli

@@ -46,6 +46,9 @@ val rem_ir : t -> int -> unit
 (** [to_list bb] are the IR operations in [bb] in order as a list. *)
 val to_list : t -> Ir.t list
 
+(** [label_for bb] is the assembler label for [bb]. *)
+val label_for : t -> string
+
 (** [equal bb1 bb2] is whether bb1 and bb2 have the same id. *)
 val equal : t -> t -> bool
 

lib/ir/ir.ml

@@ -1,5 +1,7 @@
 type constant = int
 
+module VariableMap = Hashtbl.Make (Variable)
+
 (** The kabIR for x86istmb. *)
 type t =
   | Assign of Variable.t * Operand.t

lib/ir/pass.ml

@@ -4,7 +4,7 @@ type t =
   | Repeat of t * int
 
 let make f = Basic f
-let compose pass1 pass2 = Combine [ pass1; pass2 ]
+let sequence pass1 pass2 = Combine [ pass1; pass2 ]
 let combine passes = Combine passes
 let repeat n pass = Repeat (pass, n)
 

lib/ir/pass.mli

@@ -1,7 +1,7 @@
 type t
 
 val make : (Basic_block.t * Liveliness.BasicBlockAnalysis.t -> unit) -> t
-val compose : t -> t -> t
+val sequence : t -> t -> t
 val combine : t list -> t
 val repeat : int -> t -> t
 val execute : t -> Basic_block.t -> Liveliness.BasicBlockAnalysis.t -> unit

lib/ir/passes.ml

@@ -15,20 +15,18 @@ module ConstFold : Pass.PASS = struct
 end
 
 module CopyProp : Pass.PASS = struct
-  module VariableMap = Hashtbl.Make (Variable)
-
   let copy_prop (bb, _) =
-    let vals = VariableMap.create 16 in
+    let vals = Ir.VariableMap.create 16 in
     let subs = function
       | Operand.Variable var -> (
-          match VariableMap.find_opt vals var with
+          match Ir.VariableMap.find_opt vals var with
           | Some oper -> oper
           | None -> Operand.make_var var)
       | oper -> oper
     in
     for i = 0 to Basic_block.length_of bb - 1 do
       match Basic_block.get_ir bb i with
-      | Assign (var, oper) -> VariableMap.replace vals var oper
+      | Assign (var, oper) -> Ir.VariableMap.replace vals var oper
       | Add (var, oper1, oper2) ->
           Basic_block.set_ir bb i (Add (var, subs oper1, subs oper2))
       | Sub (var, oper1, oper2) ->

lib/runtime/x86istimb_debug_print.c

@@ -0,0 +1,6 @@
+#include <stdio.h>
+#include <stdint.h>
+
+void x86istimb_debug_print(int64_t value) {
+    printf("%d\n", value);
+}

lib/user/driver.ml

@@ -22,16 +22,21 @@ let print_version () =
 
 let compile paths _ =
   Printf.printf "assumes [paths] has one file, ignores flags\n";
-  let source = Util.read_file (List.hd paths) in
+  let source_path = List.hd paths in
+  let source = Util.read_file source_path in
   try
-    let statements = Parse_lex.lex_and_parse ~filename:(List.hd paths) source in
+    let statements = Parse_lex.lex_and_parse ~filename:source_path source in
     Analysis.infer statements;
-    let ir = Ir_gen.generate statements in
-    let main_cfg = List.hd ir in
-    ignore (Liveliness.analysis_of main_cfg);
-    let simulator = Ir_sim.make () in
-    Ir_sim.run simulator main_cfg;
-    print_string (Ir_sim.output_of simulator)
+    let cfgs = Ir_gen.generate statements in
+    let main_cfg = List.hd cfgs in
+    let liveliness_analysis = Liveliness.analysis_of main_cfg in
+    let instr_ordering = InstrOrdering.make main_cfg in
+    let regalloc =
+      Regalloc.allocate_for main_cfg liveliness_analysis instr_ordering
+    in
+    Asm_emit.emit section
+    (* let simulator = Ir_sim.make () in Ir_sim.run simulator main_cfg;
+       print_string (Ir_sim.output_of simulator) *)
   with Parse_lex.ParserError msg -> print_error (msg ^ "\n")
 
 let main args =

test/test_passes.ml

@@ -32,7 +32,8 @@ let fixed_ir_opts_tests =
       ],
       "combined ir opt" );
     ( [
-        Pass.compose Passes.ConstFold.pass Passes.CopyProp.pass |> Pass.repeat 10;
+        Pass.sequence Passes.ConstFold.pass Passes.CopyProp.pass
+        |> Pass.repeat 10;
         Passes.DeadCode.pass;
       ],
       "complex ir opt" );

test/test_regalloc.ml

@@ -29,8 +29,8 @@ let basic_vars =
     let allocations = Regalloc.allocate_for cfg liveliness ordering in
     (check bool) "var0 and var1 are allocated separately" false
       (allocations_same
-         (Regalloc.VarTbl.find allocations var0)
-         (Regalloc.VarTbl.find allocations var1))
+         (Ir.VariableMap.find allocations var0)
+         (Ir.VariableMap.find allocations var1))
   in
   Alcotest.test_case "basic case" `Quick test
 
@@ -54,8 +54,8 @@ let write_after_dead =
     let allocations = Regalloc.allocate_for cfg liveliness ordering in
     (check bool) "var0 and var1 are allocated separately" false
       (allocations_same
-         (Regalloc.VarTbl.find allocations var0)
-         (Regalloc.VarTbl.find allocations var1))
+         (Ir.VariableMap.find allocations var0)
+         (Ir.VariableMap.find allocations var1))
   in
   Alcotest.test_case "write after dead" `Quick test
 
@@ -78,7 +78,7 @@ let spill_basic =
     let liveliness = Liveliness.analysis_of cfg in
     let ordering = InstrOrdering.make cfg in
     let allocations = Regalloc.allocate_for cfg liveliness ordering in
-    let alloc_list = List.map (Regalloc.VarTbl.find allocations) vars in
+    let alloc_list = List.map (Ir.VariableMap.find allocations) vars in
     List.iteri
       (fun i var1 ->
         List.iteri
@@ -120,7 +120,7 @@ let spill_special_case =
     let liveliness = Liveliness.analysis_of cfg in
     let ordering = InstrOrdering.make cfg in
     let allocations = Regalloc.allocate_for cfg liveliness ordering in
-    let alloc_list = List.map (Regalloc.VarTbl.find allocations) vars in
+    let alloc_list = List.map (Ir.VariableMap.find allocations) vars in
 
     List.iteri
       (fun i var1 ->