From d8e44d7e8e043eb5559ff7228f2bd6c4ecbce3f0 Mon Sep 17 00:00:00 2001 From: Paweł Dybiec Date: Sun, 9 Dec 2018 17:49:20 +0100 Subject: Initial code for translator --- source/mod_student/plugin.ml | 14 +-- source/mod_student/translator.ml | 209 +++++++++++++++++++++++++++++++++++++++ source/xi/.merlin | 15 +++ source/xi/pipeline.ml | 2 +- source/xi/xi.ml | 2 +- source/xi_lib/.merlin | 5 + source/xi_lib/analysis_domain.ml | 4 +- source/xi_lib/ir.ml | 65 +++++++++--- source/xi_lib/ir_utils.ml | 15 ++- source/xi_lib/logger.ml | 6 +- xisdk/mod_uwr.cma | Bin 1205101 -> 1208788 bytes 11 files changed, 304 insertions(+), 33 deletions(-) create mode 100644 source/mod_student/translator.ml create mode 100644 source/xi/.merlin create mode 100644 source/xi_lib/.merlin 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 Binary files a/xisdk/mod_uwr.cma and b/xisdk/mod_uwr.cma differ -- cgit 1.4.1