Initial code for translator

11 files changed, 304 insertions, 33 deletions

diff --git a/source/mod_student/plugin.ml b/source/mod_student/plugin.ml
index 41487d3..33e2f27 100644
--- a/source/mod_student/plugin.ml
+++ b/source/mod_student/plugin.ml
@@ -28,21 +28,17 @@ module Plugin : PLUGIN = struct
   let make_spill_costs_analysis = None
 
   let lexer_and_parser = None
+
   (*
-   * Przenieś pliki parser.mly oraz lexer.mll z poprzedniego rozwiązania 
-   * i odkomentuj poniższą linijkę.
-   *
-   * Przenoszenie rozwiązania nie jest wymagane. Pamiętaj, że możesz napotkać
-   * trudności gdy rozwiązanie z poprzedniej pracowni okaże się nie do końca
-   * kompatybilne z kształtem danych oczekiwanym przez resztę modułów
-   * kompilatora.
-   *
   let lexer_and_parser = Some (module LexerAndParser : LEXER_AND_PARSER)
    *)
 
+  let make_typechecker = None
+  (*
   let make_typechecker = Some (module Typechecker.Make : MAKE_TYPECHECKER)
+   *)
 
-  let make_translator = None
+  let make_translator = Some (module Translator.Make : MAKE_TRANSLATOR)
 
   let make_jump_threading = None
 
diff --git a/source/mod_student/translator.ml b/source/mod_student/translator.ml
new file mode 100644
index 0000000..1514319
--- /dev/null
+++ b/source/mod_student/translator.ml
@@ -0,0 +1,209 @@
+open Xi_lib
+open Ir
+
+let i32_0 = Int32.of_int 0
+let i32_1 = Int32.of_int 1
+
+(* --------------------------------------------------- *)
+
+module Make() = struct
+
+  module Environment = struct
+
+    type env = Env of
+      { procmap: procid Ast.IdMap.t
+      ; varmap: reg Ast.IdMap.t
+      }
+
+    let empty =
+      let procmap = Ast.IdMap.empty in
+      let varmap = Ast.IdMap.empty in
+      Env {procmap; varmap}
+
+
+    let add_proc id procid (Env {procmap; varmap}) =
+      let procmap = Ast.IdMap.add id procid procmap in
+      Env {procmap; varmap}
+
+    let add_var id reg (Env {procmap; varmap}) =
+      let varmap = Ast.IdMap.add id reg varmap in
+      Env {procmap; varmap}
+
+    let lookup_proc id (Env {procmap; _}) =
+      try
+        Ast.IdMap.find id procmap
+      with Not_found ->
+        failwith @@ Format.sprintf "Unknown procedure identifier: %s" (Ast.string_of_identifier id)
+
+    let lookup_var id (Env {varmap; _}) =
+      try
+        Ast.IdMap.find id varmap
+      with Not_found ->
+        failwith @@ Format.sprintf "Unknown variable identifier: %s" (Ast.string_of_identifier id)
+
+  end
+
+
+(* --------------------------------------------------- *)
+  module Scanner = struct
+
+    let mangle_id id =
+      Format.sprintf "_I_%s" (Ast.string_of_identifier id)
+
+    let rec mangle_texpr = function
+      | Ast.TEXPR_Int _ -> "i"
+      | Ast.TEXPR_Bool _ -> "b"
+      | Ast.TEXPR_Array {sub;_} -> "a" ^ mangle_texpr sub
+
+
+    let mangle_var_declaration v = mangle_texpr @@ Ast.type_expression_of_var_declaration v
+
+    let mangle_formal_parameters xs = String.concat "" (List.map mangle_var_declaration xs)
+
+    let mangle_return_types xs = String.concat "" (List.map mangle_texpr xs)
+
+    let scan_global_declaration (env, symbols) = function
+      | Ast.GDECL_Function {id; formal_parameters; return_types; _} ->
+        let name = Format.sprintf "%s_%s_%s" 
+          (mangle_id id) (mangle_formal_parameters formal_parameters) (mangle_return_types return_types)
+          in
+        
+        Environment.add_proc id (Procid name) env, Procid name :: symbols
+
+    let scan_module env (Ast.ModuleDefinition {global_declarations; _}) = 
+      List.fold_left scan_global_declaration (env, []) global_declarations
+
+  end
+(* --------------------------------------------------- *)
+
+  module type SContext = sig
+
+    val cfg : ControlFlowGraph.t
+
+    val node2type: (Ast.node_tag, Types.normal_type) Hashtbl.t
+
+    val allocate_register: unit -> reg
+  end
+
+(* --------------------------------------------------- *)
+  module Translator(M:SContext) = struct
+    open M
+
+    (* dodaj instrukcje do bloku *)
+    let append_instruction l i =
+      let block = ControlFlowGraph.block cfg l in
+      ControlFlowGraph.set_block cfg l (block @ [i])
+
+    (* ustaw terminator na skok bezwarunkowy *)
+    let set_jump l_from l_to =
+      ControlFlowGraph.set_terminator cfg l_from @@ T_Jump l_to;
+      ControlFlowGraph.connect cfg l_from l_to
+
+    (* ustaw terminator na powrót-z-procedury *)
+    let set_return l_from xs =
+      ControlFlowGraph.set_terminator cfg l_from @@ T_Return xs;
+      ControlFlowGraph.connect cfg l_from (ControlFlowGraph.exit_label cfg)
+
+    (* ustaw terminator na skok warunkowy *)
+    let set_branch cond a b l_from l_to1 l_to2 =
+      ControlFlowGraph.set_terminator cfg l_from @@ T_Branch (cond, a, b, l_to1, l_to2);
+      ControlFlowGraph.connect cfg l_from l_to1;
+      ControlFlowGraph.connect cfg l_from l_to2
+
+    let allocate_block () = ControlFlowGraph.allocate_block cfg
+
+    let i32_0 = Int32.of_int 0
+    let i32_1 = Int32.of_int 1
+
+    (* --------------------------------------------------- *)
+    let rec translate_expression env current_bb = function
+      | Ast.EXPR_Char {value; _} ->
+        current_bb, E_Int (Int32.of_int @@ Char.code value)
+
+      | Ast.EXPR_Id {id; _} ->
+        current_bb, E_Reg (Environment.lookup_var id env)
+
+      | _ ->
+        failwith "not yet implemented"
+
+    (* --------------------------------------------------- *)
+    and translate_condition env current_bb else_bb = function 
+      | Ast.EXPR_Bool {value=true; _} ->
+        current_bb
+
+      | Ast.EXPR_Bool {value=false; _} ->
+        set_jump current_bb else_bb;
+        allocate_block ()
+
+      (* Zaimplementuj dodatkowe przypadki *)
+
+      | e ->
+        let current_bb, res = translate_expression env current_bb e in
+        let next_bb = allocate_block () in 
+        set_branch COND_Ne res (E_Int i32_0) current_bb next_bb else_bb;
+        next_bb
+
+
+    (* --------------------------------------------------- *)
+
+    let rec translate_statement env current_bb = function
+      | _ ->
+        failwith "not yet implemented"
+
+
+    and translate_block env current_bb (Ast.STMTBlock {body; _}) =
+      failwith "not yet implemented"
+
+    let bind_var_declaration env vardecl =
+      let r = allocate_register () in
+      let env = Environment.add_var (Ast.identifier_of_var_declaration vardecl) r env in
+      env, r
+
+    let bind_formal_parameters env xs =
+      let f env x = fst (bind_var_declaration env x) in 
+      List.fold_left f env xs
+
+  let translate_global_definition env = function
+    | Ast.GDECL_Function {id; body=Some body; formal_parameters;_} ->
+      let procid = Environment.lookup_proc id env in 
+      let frame_size = 0 in
+      let env = bind_formal_parameters env formal_parameters in
+      let formal_parameters = List.length formal_parameters in
+      let proc = Procedure {procid; cfg; frame_size; allocate_register; formal_parameters} in
+      let first_bb = allocate_block () in
+      let _, last_bb = translate_block env first_bb body in 
+      ControlFlowGraph.connect cfg  last_bb (ControlFlowGraph.exit_label cfg);
+      ControlFlowGraph.connect cfg  (ControlFlowGraph.entry_label cfg) first_bb;
+      [proc]
+    
+    | _ ->
+      []
+
+  end
+
+  let make_allocate_register () = 
+    let counter = ref 0 in
+    fun () ->
+      let i = !counter in
+      incr counter;
+      REG_Tmp i
+
+
+    let translate_global_definition node2type env gdef = 
+      let cfg = ControlFlowGraph.create () in
+      let module T = Translator(struct
+        let cfg = cfg
+        let node2type = node2type
+        let allocate_register = make_allocate_register ()
+      end) in
+      T.translate_global_definition env gdef
+
+    let translate_module node2type env (Ast.ModuleDefinition {global_declarations; _}) =
+      List.flatten @@ List.map (translate_global_definition node2type env) global_declarations
+
+    let translate_module mdef node2type =
+      let env = Environment.empty in
+      let env, symbols = Scanner.scan_module env mdef in
+      let procedures = translate_module node2type env mdef in
+      Program {procedures; symbols}
+  end
diff --git a/source/xi/.merlin b/source/xi/.merlin
new file mode 100644
index 0000000..dc01a8e
--- /dev/null
+++ b/source/xi/.merlin
@@ -0,0 +1,15 @@
+B /home/wieczyk/.opam/4.07.0/lib/bytes
+B /home/wieczyk/.opam/4.07.0/lib/cmdliner
+B /home/wieczyk/.opam/4.07.0/lib/ocaml
+B /home/wieczyk/.opam/4.07.0/lib/ocamlgraph
+B /home/wieczyk/.opam/4.07.0/lib/result
+B ../../_build/default/source/xi/.xi.eobjs
+B ../../_build/default/source/xi_lib/.xi_lib.objs
+S /home/wieczyk/.opam/4.07.0/lib/bytes
+S /home/wieczyk/.opam/4.07.0/lib/cmdliner
+S /home/wieczyk/.opam/4.07.0/lib/ocaml
+S /home/wieczyk/.opam/4.07.0/lib/ocamlgraph
+S /home/wieczyk/.opam/4.07.0/lib/result
+S .
+S ../xi_lib
+FLG -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs -g -w -39-33-26-27
diff --git a/source/xi/pipeline.ml b/source/xi/pipeline.ml
index ae9a4c9..190a3f3 100644
--- a/source/xi/pipeline.ml
+++ b/source/xi/pipeline.ml
@@ -22,7 +22,7 @@ module Make(Steps:COMPILER_STEPS)(Params:PARAMS) = struct
 
   let describe_register_mapping mapping =
     let describe_map k v xs =
-      let entry = Format.sprintf "%s -> %s" (Ir.string_of_reg k) (Ir.string_of_reg v) in
+      let entry = Format.sprintf "%s -> %s" (Ir_utils.string_of_reg k) (Ir_utils.string_of_reg v) in
       entry :: xs
     in
     String.concat "\n" @@ Hashtbl.fold describe_map mapping []
diff --git a/source/xi/xi.ml b/source/xi/xi.ml
index d59dbf6..c54a499 100644
--- a/source/xi/xi.ml
+++ b/source/xi/xi.ml
@@ -72,7 +72,7 @@ module CommandLine = struct
 
   let cmd =
     let doc = "Compile Xi Program" in
-    let version = "pracownia2.3-0-g63fd12e" in
+    let version = "pracownia3.1-0-g147dd61" in
     Term.(const compile $ xi_log $ extra_debug $ mod_uwr $ plugin $ reg_descr $ stop_after $ output $ source_file),
     Term.info "xi" ~doc ~version
 
diff --git a/source/xi_lib/.merlin b/source/xi_lib/.merlin
new file mode 100644
index 0000000..e44069f
--- /dev/null
+++ b/source/xi_lib/.merlin
@@ -0,0 +1,5 @@
+B /home/wieczyk/.opam/4.07.0/lib/ocamlgraph
+B ../../_build/default/source/xi_lib/.xi_lib.objs
+S /home/wieczyk/.opam/4.07.0/lib/ocamlgraph
+S .
+FLG -open Xi_lib -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs
diff --git a/source/xi_lib/analysis_domain.ml b/source/xi_lib/analysis_domain.ml
index 9f49a3e..db124e0 100644
--- a/source/xi_lib/analysis_domain.ml
+++ b/source/xi_lib/analysis_domain.ml
@@ -103,7 +103,7 @@ module ConstantFolding = struct
     | Some a -> Ir_utils.string_of_expr a
 
   let string_of_domain dom =
-    let f (k,v) = Format.sprintf "%s=%s" (Ir.string_of_reg k) (string_of_el v) in
+    let f (k,v) = Format.sprintf "%s=%s" (Ir_utils.string_of_reg k) (string_of_el v) in
     let seq = Ir.RegMap.to_seq dom in
     let seq = Seq.map f seq in
     String.concat " " @@ List.of_seq seq
@@ -132,4 +132,4 @@ module ReachabilityAnalysis = struct
 
   type table = Ir.LabelSet.t Analysis.BlockKnowledge.table
 
-end
\ No newline at end of file
+end
diff --git a/source/xi_lib/ir.ml b/source/xi_lib/ir.ml
index b611916..f7d2c96 100644
--- a/source/xi_lib/ir.ml
+++ b/source/xi_lib/ir.ml
@@ -1,12 +1,11 @@
 type reg
+    (* rejestr tymczasowy *)
   = REG_Tmp of int
+    (* rejestr sprzętowy *)
   | REG_Hard of int
+    (* rejestr sprzętowy specjalnego przeznaczenia *)
   | REG_Spec of int
 
-let string_of_reg = function
-  | REG_Tmp i -> Format.sprintf "%%tmp%u" i
-  | REG_Hard i -> Format.sprintf "%%hard%u" i
-  | REG_Spec i -> Format.sprintf "%%spec%u" i
 
 let is_spec_reg = function
   | REG_Spec _ -> true
@@ -69,49 +68,74 @@ type cond
   | COND_Le
   | COND_Ge
 
-let string_of_cond = function
-  | COND_Eq -> "eq"
-  | COND_Ne -> "ne"
-  | COND_Lt -> "lt"
-  | COND_Gt -> "gt"
-  | COND_Le -> "le"
-  | COND_Ge -> "ge"
-
 
 type instr
+    (* dodaj *)
   = I_Add of reg * expr * expr
+    (* odejmij *)
   | I_Sub of reg * expr * expr
+    (* podziel *)
   | I_Div of reg * expr * expr
+    (* reszta z dzielenia *)
   | I_Rem of reg * expr * expr
+    (* pomnóż *)
   | I_Mul of reg * expr * expr
+    (* bitowy and *)
   | I_And of reg * expr * expr
+    (* bitowy or *)
   | I_Or of reg * expr * expr
+    (* bitowy xor *)
   | I_Xor of reg * expr * expr
+    (* LoadArray(r, xs, i) oznacza załaduj i-ty element tablicy xs do rejestru r *)
   | I_LoadArray of reg * expr * expr
+    (* StoreArray(xs, i, e) oznacza zapisz do i-tego elementu tablicy xs atom e *)
   | I_StoreArray of expr * expr * expr
+    (* LoadMem(r, xs, i) oznacza załaduj komórkę pamięci o adresie (xs+i) do rejestru r*)
   | I_LoadMem of reg * expr * expr
+    (* StoreMem(xs, i, e) oznacza zapisz do komórki pamięci o adresie (xs+i) atom e *)
   | I_StoreMem of expr * expr * expr
+    (* wysokopoziomowa instrukcja: konkatenacja tablic *)
   | I_Concat of reg * expr * expr
+    (* zaneguj liczbę *)
   | I_Neg of reg * expr
+    (* bitowy not *)
   | I_Not of reg * expr
+    (* zapisz atom do rejestru *)
   | I_Move of reg * expr
+    (* wysokopoziomowa instrukcja: zapisuje do rejestru długość tablicy *)
   | I_Length of reg * expr
+    (* wysokopoziomowa instrukcja: zaalokuj tablicę o określonym rozmiarze *)
   | I_NewArray of reg * expr
+    (* I_Call(rs, p, xs, ms) oznacza wywołaj p z argumentami xs, wyniki
+     * funkcji znajdą się w rejestrach rs, dodatkowo zostaną zmodyfikowane rejestry ms *)
   | I_Call of reg list * procid * expr list * reg list
-  | I_Set of reg * cond * expr * expr  
+    (* I_Set(r, cond, a, b) zapisz do rejestru r wartość boolowską warunku cond(a,b) *)
+  | I_Set of reg * cond * expr * expr
+    (* załaduj do rejestru zmienną lokalną *)
   | I_LoadVar of reg * int
+    (* zapisz atom do zmiennej lokalnej *)
   | I_StoreVar of int * expr
+    (* załaduj do rejestru komórkę ze stosu *)
   | I_LoadStack of reg * int
+    (* zapisz do komórki na stosie atom *)
   | I_StoreStack of int * expr
+    (* przydziel stos *)
   | I_StackAlloc of Int32.t
+    (* zwolnij stos *)
   | I_StackFree of Int32.t
+    (* meta-instrukcja, podane rejestry będą uznawane za użyte *)
   | I_Use of reg list
+    (* meta-instrukcja, podane rejestry będą uznane za zmodyfikowane *)
   | I_Def of reg list
 
 
 type terminator =
+    (* return *)
   | T_Return of expr list
+    (* T_Branch(cond, a, b, then_bb, else_bb) oznacza skok warunkowy
+     * if cond(a,b) then goto then_bb else goto else_bb *)
   | T_Branch of cond * expr * expr * label * label
+    (* skok bezwarunkowy *)
   | T_Jump of label 
 
 let labels_of_terminator = function
@@ -122,13 +146,13 @@ let labels_of_terminator = function
 type block = instr list
 
 module LabelGraph = Graph.Imperative.Digraph.ConcreteBidirectional(struct 
-(*module LabelGraph = Mygraph.MakeBidirectional(struct *)
   type t = label
   let compare = compare
   let hash = Hashtbl.hash
   let equal a b = a = b
   end)
 
+(* Reprezentacja ciała funkcji *)
 module ControlFlowGraph = struct
 
   type graph = LabelGraph.t 
@@ -253,11 +277,17 @@ module ControlFlowGraph = struct
 
 end
 
+(* Reprezentacja całej procedury *)
 type procedure = Procedure of
+    (* identyfikator *)
   { procid: procid
+    (* graf sterowania *)
   ; cfg: ControlFlowGraph.t
+    (* rozmiar rekordu aktywacji *)
   ; mutable frame_size: int
+    (* ilość parametrów formalnych *)
   ; formal_parameters: int
+    (* funkcja do przydzielania świeżych rejestrów wewnątrz danej proceduy *)
   ; allocate_register: unit -> reg
   }
 
@@ -278,11 +308,14 @@ let procid_of_procedure (Procedure {procid; _}) = procid
 let frame_size_of_procedure (Procedure {frame_size; _}) = frame_size
 
 
+(* Reprezentacja programu *)
 type program = Program of
+    (* lista procedur *)
   { procedures: procedure list
-  ; externals: procid list
+    (* lista wszystkich symboli *)
+  ; symbols: procid list
   }
 
 let procedures_of_program (Program{procedures; _}) = procedures
 
-let externals_of_program (Program{externals; _}) = externals
+let symbols_of_program (Program{symbols; _}) = symbols
diff --git a/source/xi_lib/ir_utils.ml b/source/xi_lib/ir_utils.ml
index 48b59a1..b43655d 100644
--- a/source/xi_lib/ir_utils.ml
+++ b/source/xi_lib/ir_utils.ml
@@ -1,5 +1,18 @@
 open Ir
 
+let string_of_reg = function
+  | REG_Tmp i -> Format.sprintf "%%tmp%u" i
+  | REG_Hard i -> Format.sprintf "%%hard%u" i
+  | REG_Spec i -> Format.sprintf "%%spec%u" i
+
+let string_of_cond = function
+  | COND_Eq -> "eq"
+  | COND_Ne -> "ne"
+  | COND_Lt -> "lt"
+  | COND_Gt -> "gt"
+  | COND_Le -> "le"
+  | COND_Ge -> "ge"
+
 let remap_register_reg sb r = 
   try
     Hashtbl.find sb r
@@ -665,4 +678,4 @@ let string_of_module_definition xs =
   String.concat "\n" @@ List.map string_of_procedure xs
 
 let string_of_program (Program {procedures; _}) =
-  String.concat "\n" @@ List.map string_of_procedure procedures
\ No newline at end of file
+  String.concat "\n" @@ List.map string_of_procedure procedures
diff --git a/source/xi_lib/logger.ml b/source/xi_lib/logger.ml
index 746bbb8..26ce286 100644
--- a/source/xi_lib/logger.ml
+++ b/source/xi_lib/logger.ml
@@ -134,7 +134,7 @@ let dump_ir_proc title irproc =
   dump_string title buffer
 
 let dump_spill_costs spill_costs =
-  let f (k,v) = Format.sprintf "%s -> %u" (Ir.string_of_reg k) v in 
+  let f (k,v) = Format.sprintf "%s -> %u" (Ir_utils.string_of_reg k) v in 
   let seq = Hashtbl.to_seq spill_costs in
   let seq = Seq.map f seq in
   let seq = List.of_seq seq in
@@ -142,7 +142,7 @@ let dump_spill_costs spill_costs =
   dump_string "spill_costs" buf
 
 let dump_spill_costs_f spill_costs =
-  let f (k,v) = Format.sprintf "%s -> %f" (Ir.string_of_reg k) v in 
+  let f (k,v) = Format.sprintf "%s -> %f" (Ir_utils.string_of_reg k) v in 
   let seq = Hashtbl.to_seq spill_costs in
   let seq = Seq.map f seq in
   let seq = List.of_seq seq in
@@ -167,4 +167,4 @@ let dump_constant_folding title cfg table =
   dump_string (title ^ ".cfa.xdot") buffer
 
 let init xilog =
-  FS.init xilog
\ No newline at end of file
+  FS.init xilog
diff --git a/xisdk/mod_uwr.cma b/xisdk/mod_uwr.cma
index 1bb9965..827e6e2 100644
--- a/xisdk/mod_uwr.cma
+++ b/xisdk/mod_uwr.cma