diff options
46 files changed, 5359 insertions, 0 deletions
diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..c6077e0 --- /dev/null +++ b/Makefile @@ -0,0 +1,28 @@ +.PHONY: all compile clean test +BUILD_PATH_XI=./_build/install/default/bin/xi +BUILD_PATH_MOD_UWR=./_build/install/default/lib/mod_uwr/mod_uwr.cma +BUILD_PATH_MOD_STUDENT=./_build/install/default/lib/mod_student/mod_student.cma +all: compile + +compile: + dune build + +install: all + rm -f ./xi + rm -rf mods + mkdir mods + if [ -e ${BUILD_PATH_MOD_STUDENT} ]; then (cd mods; ln -s ../${BUILD_PATH_MOD_STUDENT} .); fi + if [ -e ${BUILD_PATH_MOD_UWR} ]; then (cd xisdk; rm -f mod_uwr.cma; ln -s ../${BUILD_PATH_MOD_UWR} .); fi + if [ -e ${BUILD_PATH_MOD_STUDENT} ]; then (cd mods; rm -f mod_student.cma; ln -s ../${BUILD_PATH_MOD_STUDENT} .); fi + ln -s ${BUILD_PATH_XI} ./xi + +test: all + python3 ./tools/tester.py --plugin mods/mod_student.cma + +test_without_plugin: all + python3 ./tools/tester.py + +clean: + rm -f ./xi + dune clean + diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..977e7d7 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.1) +(using menhir 1.0) diff --git a/dune-workspace b/dune-workspace new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/dune-workspace diff --git a/mod_student.opam b/mod_student.opam new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/mod_student.opam diff --git a/source/mod_student/.merlin b/source/mod_student/.merlin new file mode 100644 index 0000000..e07c2b1 --- /dev/null +++ b/source/mod_student/.merlin @@ -0,0 +1,7 @@ +B /home/wieczyk/.opam/4.07.0/lib/ocamlgraph +B ../../_build/default/source/mod_student/.mod_student.objs +B ../../_build/default/source/xi_lib/.xi_lib.objs +S /home/wieczyk/.opam/4.07.0/lib/ocamlgraph +S . +S ../xi_lib +FLG -open Mod_student -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-32 diff --git a/source/mod_student/dune b/source/mod_student/dune new file mode 100644 index 0000000..c590740 --- /dev/null +++ b/source/mod_student/dune @@ -0,0 +1,21 @@ +(library + (name mod_student) + (public_name mod_student) + (libraries ocamlgraph xi_lib) + (modes byte) +) +(menhir + (flags (--explain --dump)) + (modules parser) +) +(ocamllex + lexer +) +(env + (dev + (flags (:standard -g -w -39-33-26-27-32)) + ) + (release + (flags (:standard -w -39-33-26-27)) + ) +) diff --git a/source/mod_student/lexer.mll b/source/mod_student/lexer.mll new file mode 100644 index 0000000..4cd656c --- /dev/null +++ b/source/mod_student/lexer.mll @@ -0,0 +1,79 @@ +{ + open Xi_lib + open Parser + open Parser_utils + + (* Lexing z biblioteki standardowej ocamla *) + open Lexing + + (* Standardowo w YACC-podobnych narzędziach to lekser jest uzależniony od parsera. To znaczy, że typ + * danych z tokenami definiuje moduł wygenerowany na bazie grammar.mly. Definiujemy alias na typ + * tokenu na potrzeby interfejsów Xi_lib.Iface *) + type token = Parser.token + + (* Obsługa błędu *) + let handleError pos token = + let exc = InvalidToken (mkLocation pos, token) in + raise exc + + (* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + * Miejsce na twój kod w Ocamlu + *) + + + (* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ----------------------------------------------------------------------------- *) + + } + + (* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + * Miejsce na nazwane wyrażenia regularne + *) + + let identifier = ['a'-'z' '_' 'A' - 'Z']['_' 'A' - 'Z' 'a'-'z' '0'-'9']* + + (* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ----------------------------------------------------------------------------- *) + + + rule token = parse + (* Trzeba pamiętać aby uaktualnić pozycje w lexbuf, gdy widzimy znak końca wiersza. + * To się samo nie robi. Moduł Lexing z standardowej biblioteki daje do tego wygodną + * funkcję new_line. + *) + | ['\n'] + { new_line lexbuf; token lexbuf } + + (* widzimy początek komentarza i przechodzimy do pomocniczego stanu *) + | "//" + { line_comment lexbuf } + + | eof + { EOF } + + (* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + * Miejsce na twoje reguły + *) + + | identifier as id + { failwith id } + + (* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ----------------------------------------------------------------------------- *) + + | _ + { handleError (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme lexbuf) } + + (* Pomocniczy stan aby wygodnie i prawidłowo obsłużyć komentarze *) + and line_comment = parse + | '\n' + { new_line lexbuf; token lexbuf } + + (* Niektóre edytory nie wstawiają znaku końca wiersza w ostatniej linijce, jesteśmy + * przygotowani na obsługę takiego komentarza. + *) + | eof + { EOF } + + | _ + { line_comment lexbuf } diff --git a/source/mod_student/parser.mly b/source/mod_student/parser.mly new file mode 100644 index 0000000..3eacf51 --- /dev/null +++ b/source/mod_student/parser.mly @@ -0,0 +1,70 @@ +(* + * Menhir wygeneruje funkcję o nazwie file + *) +%start <Xi_lib.Ast.module_definition> file + +%{ +open Xi_lib +open Ast +open Parser_utils + +(* Generator znaczników *) +let mkTag = + let i = ref 0 in + fun () -> + let tag = !i in + incr i; + NodeTag tag + +(* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + * Miejsce na twój kod w Ocamlu + *) + +(* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ----------------------------------------------------------------------------- *) + +%} + +(* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + * Miejsce na dyrektywy + *) + +%token EOF +%token <string>IDENTIFIER + +(* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ----------------------------------------------------------------------------- *) + +%% + +(* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + * Miejsce na gramatykę + *) + + +(* Obecnie potrafimy sparsować tylko pusty plik (wymagamy od razu tokena EOF) *) +file: + | EOF + { ModuleDefinition {global_declarations=[] } } + + +identifier: + | IDENTIFIER + { Identifier $1 } + +(* + ** przykład użycia mkLocation + + use_declaration: + | USE suffix(identifier, opt(SEMICOLON)) + { GDECL_Use {loc=mkLocation $startpos; id=$2} } + + ** przykład użycia mkTag + + atomic_expression: + | identifier + { EXPR_Id {loc=mkLocation $startpos; id=$1; tag=mkTag ()} } +*) + +(* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ----------------------------------------------------------------------------- *) diff --git a/source/mod_student/plugin.ml b/source/mod_student/plugin.ml new file mode 100644 index 0000000..26d15d0 --- /dev/null +++ b/source/mod_student/plugin.ml @@ -0,0 +1,61 @@ +open Xi_lib.Iface +open Xi_lib.Plugin +open Xi_lib.Plugin_register + + +module LexerAndParser = struct + + type token = Parser.token + + module Lexer = Lexer + + module Parser = Parser + +end + +module Plugin : PLUGIN = struct + + let version = "na" + + let make_live_variables_analysis = None + + let make_dominators_analysis = None + + let make_scheduler = None + + let make_natural_loops_analysis = None + + let make_spill_costs_analysis = None + + let lexer_and_parser = Some (module LexerAndParser : LEXER_AND_PARSER) + + let make_typechecker = None + + let make_translator = None + + let make_jump_threading = None + + let make_constant_folding = None + + let make_hilower = None + + let make_callconv = None + + let make_mipslower = None + + let make_register_allocator = None + + let make_constant_folding_analysis = None + + let make_codegen = None + + let make_dead_code_elimination = None + + let make_interference_graph_analysis = None + + let make_spilling = None + + let make_reachability_analysis = None +end + +module RegisterMyPlugin = RegisterPlugin(Plugin) \ No newline at end of file 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/dune b/source/xi/dune new file mode 100644 index 0000000..1c209ac --- /dev/null +++ b/source/xi/dune @@ -0,0 +1,15 @@ +(executable + (name xi) + (public_name xi) + (modes byte) + (libraries cmdliner ocamlgraph unix xi_lib dynlink) + (package xi) +) +(env + (dev + (flags (:standard -g -w -39-33-26-27)) + ) + (release + (flags (:standard -w -39-33-26-27)) + ) +) diff --git a/source/xi/invariants.ml b/source/xi/invariants.ml new file mode 100644 index 0000000..09c8b86 --- /dev/null +++ b/source/xi/invariants.ml @@ -0,0 +1,146 @@ +open Xi_lib +open Ast +open Types + + +module AllExpressionsAreTypecheck = struct + + exception MissingTypeInformation of location + + module Implementation(M:sig val node2type: (node_tag, normal_type) Hashtbl.t end) = struct + + open M + + let check_tag loc tag = + match Hashtbl.find_opt node2type tag with + | Some _ -> () + | None -> raise (MissingTypeInformation loc) + + let expr_subexpressions = function + | EXPR_Id _ -> [] + | EXPR_Int _ -> [] + | EXPR_Char _ -> [] + | EXPR_String _ -> [] + | EXPR_Bool _ -> [] + + | EXPR_Relation {lhs; rhs; _} -> + [lhs; rhs] + + | EXPR_Binop {lhs; rhs; _} -> + [lhs; rhs] + + | EXPR_Length {arg; _} -> + [arg] + + | EXPR_Unop {sub; _} -> + [sub] + + | EXPR_Call (Call {arguments; _}) -> + arguments + + | EXPR_Index {expr; index; _} -> + [expr; index] + + | EXPR_Struct {elements; _} -> + elements + + let some2list = function + | Some x -> [x] + | None -> [] + + let block_substatements = function + | STMTBlock {body; _} -> body + + let block_substatements_opt = function + | Some (STMTBlock {body; _}) -> body + | None -> [] + + let stmt_subexpressions = function + | STMT_Call (Call {arguments; _}) -> + arguments + + | STMT_Assign {rhs; _} -> + [rhs] + + | STMT_VarDecl {init=Some init; _} -> + [init] + + | STMT_VarDecl {init=None; _} -> + [] + + | STMT_If {cond; _} -> + [cond] + + | STMT_While {cond; _} -> + [cond] + + | STMT_Return {values; _} -> + values + + | STMT_MultiVarDecl {init=Call{arguments; _}; _} -> + arguments + + | STMT_Block _ -> + [] + + let stmt_substatements = function + | STMT_Call _ -> + [] + + | STMT_Assign _ -> + [] + + | STMT_VarDecl _ -> + [] + + | STMT_If {then_branch; else_branch; _} -> + [then_branch] @ some2list else_branch + + | STMT_While {body; _} -> + [body] + + | STMT_Return _ -> + [] + + | STMT_MultiVarDecl _ -> + [] + + | STMT_Block block -> + block_substatements block + + + let rec verify_expression e = + check_tag (location_of_expression e) (tag_of_expression e); + let sube = expr_subexpressions e in + List.iter verify_expression sube + + let rec verify_statement s = + let exprs = stmt_subexpressions s in + let stmts = stmt_substatements s in + List.iter verify_expression exprs; + List.iter verify_statement stmts + + let verify_block_opt s = + let stmts = block_substatements_opt s in + List.iter verify_statement stmts + + + let verify_global_declaration = function + | GDECL_Function {body; _} -> + verify_block_opt body + + let verify_module_definition (ModuleDefinition {global_declarations}) = + List.iter verify_global_declaration global_declarations + + end + + let verify_module_definition node2tag mdef = + try + let module Instance = Implementation(struct let node2type = node2tag end) in + Instance.verify_module_definition mdef; + true + with MissingTypeInformation e -> + Format.eprintf "Missing type information for expression %s\n%!" (string_of_location e); + false + +end \ No newline at end of file diff --git a/source/xi/parser_wrapper.ml b/source/xi/parser_wrapper.ml new file mode 100644 index 0000000..4b371c5 --- /dev/null +++ b/source/xi/parser_wrapper.ml @@ -0,0 +1,42 @@ +open Xi_lib +open Iface + +module Make(LP:LEXER_AND_PARSER) = struct + + module L = LP.Lexer + + module P = LP.Parser + + let open_file_lexbuf file = + let channel = open_in file in + let lexbuf = Lexing.from_channel channel in + (* Wpisujemy nazwe pliku (katalog ze ścieżki ucina Filename.basename) + * do lexbuf. Dzięki temu Parser_utils.makeLocation będzie mógł lokacje + * uzupełniać o prawidłową nazwę pliku. + *) + lexbuf.Lexing.lex_curr_p <- { + lexbuf.Lexing.lex_curr_p with + Lexing.pos_fname = Filename.basename file + }; + lexbuf + + let parse_lexbuf f lexbuf = + try + Ok (P.file L.token lexbuf); + with + | P.Error -> + let loc = Parser_utils.mkLocation lexbuf.Lexing.lex_curr_p in + let token = Lexing.lexeme lexbuf in + let s = if String.length token > 0 + then Printf.sprintf "syntax error: unexpected token: %s" token + else Printf.sprintf "syntax error: unexpected end" + in + Error (loc, s) + + | Parser_utils.InvalidToken (loc, str) -> + let s = Printf.sprintf "syntax error: invalid token: %s" str in + Error (loc, s) + + let parse_file f = parse_lexbuf f (open_file_lexbuf f) +end + diff --git a/source/xi/pipeline.ml b/source/xi/pipeline.ml new file mode 100644 index 0000000..34a06f9 --- /dev/null +++ b/source/xi/pipeline.ml @@ -0,0 +1,137 @@ +open Xi_lib +open Iface + +module type PARAMS = sig + val stop_point : string + val output: string +end + +module Make(Steps:COMPILER_STEPS)(Params:PARAMS) = struct + + module Hack = Xi_lib.Analysis + + open Params + module Toolbox = Steps.Toolbox + + module Parser_wrapper = Parser_wrapper.Make(Steps.LexerAndParser) + + let check_stop_point name cont x = + if name = stop_point then Ok () + else cont x + + + 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 + entry :: xs + in + String.concat "\n" @@ Hashtbl.fold describe_map mapping [] + + let dump_register_mapping proc_ir mapping = + Logger.dump_string "regmapping" @@ describe_register_mapping mapping + + let dump_schedule proc_ir schedule = + let title = Format.sprintf "%s.schedule" (Ir_utils.string_of_procid @@ Ir.procid_of_procedure proc_ir) in + let output = Ir_utils.string_of_labellist schedule in + Logger.dump_string title output + + module IrPhases = struct + + let regalloc proc = + let register_mapping = Steps.RegisterAllocator.regalloc proc in + dump_register_mapping proc register_mapping; + Ir_utils.remap_registers_proc register_mapping proc + + let scale_to_program f name ir = + let handle_proc proc = + Logger.new_phase_proc @@ Ir.procid_of_procedure proc; + Measure.measure name (fun () -> f proc); + Logger.dump_ir_proc "final.irproc" proc + in + Measure.measure ("whole " ^ name) (fun () -> + List.iter handle_proc @@ Ir.procedures_of_program ir; + Logger.close_phase_proc () + ); + Logger.dump_ir_program "final.ir" ir + + let ir_phases = + [ "jump_threading", scale_to_program Steps.JumpThreading.jump_threading + ; "hi_lower", scale_to_program Steps.HiLower.lower + ; "constant_folding", scale_to_program Steps.ConstantFolding.fold_constants + ; "dead_code_elimination", scale_to_program Steps.DeadCodeElimination.eliminate_dead_code + ; "callconv", scale_to_program Steps.CallConv.callconv + ; "mips_lower", scale_to_program Steps.MipsLower.lower + ; "regalloc", scale_to_program regalloc + ; "dead_code_elimination", scale_to_program Steps.DeadCodeElimination.eliminate_dead_code + ] + + + let rec execute_ir_phases ir = function + | [] -> + () + | (name, f)::rest -> + Logger.new_phase name; + f name ir; + execute_ir_phases ir rest + + let transform_ir ir = + execute_ir_phases ir ir_phases + + end + + let finish result = + Format.printf "done\n"; + let out = open_out output in + output_string out result; + output_string out "\n"; + close_out out; + Ok () + + let codegen ir = + Logger.new_phase "codegen"; + let schedule = Toolbox.Scheduler.schedule ir in + Hashtbl.iter dump_schedule schedule; + let assembler = Steps.Codegen.codegen schedule ir in + let result = Hardcoded.preamble ^ Mips32.string_of_program assembler in + Logger.dump_string "final" result; + finish result + + let translate (ast, node2type) = + Logger.new_phase "translate"; + let ir = Steps.Translator.translate_module ast node2type in + Logger.dump_ir_program "translated.ir" ir; + IrPhases.transform_ir ir; + codegen ir + + let type_check ast = + Logger.new_phase "typechecking"; + match Steps.Typechecker.check_module ast with + | Error xs -> + let xs = List.map Typechecker_errors.string_of_type_checking_error xs in + List.iter prerr_endline xs; + Error "typechecker" + | Ok (node2type) -> + if Invariants.AllExpressionsAreTypecheck.verify_module_definition node2type ast then + check_stop_point "typechecker" translate (ast, node2type) + else + Error "typechecker" + + + let parse_step source = + Logger.new_phase "parsing"; + match Parser_wrapper.parse_file source with + | Error (loc, descr) -> + Format.printf "%s: %s\n%!" (Ast.string_of_location loc) descr; + Error "parser" + + | Ok ok -> + let ast_str = Ast_printer.show_module_definition ok in + Logger.dump_string "ast" ast_str; + let ast_str = Ast_rawprinter.show_module_definition ok in + Logger.dump_string "raw.ast" ast_str; + check_stop_point "parser" type_check ok + + + let compile = + parse_step +end diff --git a/source/xi/plugin_manager.ml b/source/xi/plugin_manager.ml new file mode 100644 index 0000000..3c6cdf0 --- /dev/null +++ b/source/xi/plugin_manager.ml @@ -0,0 +1,245 @@ +open Xi_lib +open Plugin_register + +type plugin = string * (module Plugin.PLUGIN) + +module Getters = struct + + let make_live_variables_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_live_variables_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_dominators_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_dominators_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_reachability_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_reachability_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_scheduler (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_scheduler with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_natural_loops_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_natural_loops_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_spill_costs_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_spill_costs_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let lexer_and_parser (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.lexer_and_parser with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_typechecker (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_typechecker with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_translator (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_translator with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_jump_threading (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_jump_threading with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_constant_folding (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_constant_folding with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_hilower (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_hilower with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_callconv (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_callconv with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_mipslower (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_mipslower with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_register_allocator (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_register_allocator with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_dead_code_elimination (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_dead_code_elimination with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_codegen (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_codegen with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_constant_folding_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_constant_folding_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_interference_graph_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_interference_graph_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_spilling (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_spilling with + | Some x -> Some (name, Plugin.version, x) + | None -> None +end + +module Resolver = struct + + let rec find_module name getter = function + | [] -> + failwith @@ Format.sprintf "Cannot find %s" name + | x::xs -> + match getter x with + | Some (modname, version, impl) -> + Format.eprintf "module %s=%s:%s\n%!" name modname version; + impl + | None -> + find_module name getter xs + + let make_live_variables_analysis = find_module "MakeLiveVariablesAnalysis" Getters.make_live_variables_analysis + + let make_dominators_analysis = find_module "MakeDominanceAnalysis" Getters.make_dominators_analysis + + let make_reachability_analysis = find_module "MakeReachabilityAnalysis" Getters.make_reachability_analysis + + let make_scheduler = find_module "MakeScheduler" Getters.make_scheduler + + let make_natural_loops_analysis = find_module "MakeNaturalLoopsAnalysis" Getters.make_natural_loops_analysis + + let make_spill_costs_analysis = find_module "MakeSpillCostsAnalysis" Getters.make_spill_costs_analysis + + let lexer_and_parser = find_module "LexerAndParser" Getters.lexer_and_parser + + let make_typechecker = find_module "MakeTypechecker" Getters.make_typechecker + + let make_translator = find_module "MakeTranslator" Getters.make_translator + + let make_jump_threading = find_module "MakeJumpThreading" Getters.make_jump_threading + + let make_constant_folding = find_module "MakeConstantFolding" Getters.make_constant_folding + + let make_hilower = find_module "MakeHiLower" Getters.make_hilower + + let make_callconv = find_module "MakeCallConv" Getters.make_callconv + + let make_mipslower = find_module "MakeMipsLower" Getters.make_mipslower + + let make_register_allocator = find_module "MakeRegisterAllocator" Getters.make_register_allocator + + let make_dead_code_elimination = find_module "MakeDeadCodeElimination" Getters.make_dead_code_elimination + + let make_codegen = find_module "MakeCodegen" Getters.make_codegen + + let make_constant_folding_analysis = find_module "MakeConstantFoldingAnalysis" Getters.make_constant_folding_analysis + + let make_interference_graph_analysis = find_module "MakeInterferenceGraphAnalysis" Getters.make_interference_graph_analysis + + let make_spilling = find_module "MakeSpilling" Getters.make_spilling + +end + +let resolve_compiler_toolbox regdescr = + let module MakeLiveVariablesAnalysis = (val Resolver.make_live_variables_analysis !register) in + let module MakeDominatorsAnalysis = (val Resolver.make_dominators_analysis !register) in + let module MakeNaturalLoopsAnalysis = (val Resolver.make_natural_loops_analysis !register) in + let module MakeSpillCostsAnalysis = (val Resolver.make_spill_costs_analysis !register) in + let module MakeScheduler = (val Resolver.make_scheduler !register) in + let module MakeConstantFoldingAnalysis = (val Resolver.make_constant_folding_analysis !register) in + let module MakeInterferenceGraphAnalysis = (val Resolver.make_interference_graph_analysis !register) in + let module MakeSpilling = (val Resolver.make_spilling !register) in + let module MakeReachabilityAnalysis = (val Resolver.make_reachability_analysis !register) in + let module M = struct + module LiveVariablesAnalysis = MakeLiveVariablesAnalysis() + module DominatorsAnalysis = MakeDominatorsAnalysis() + module Scheduler = MakeScheduler() + module NaturalLoopsAnalysis = MakeNaturalLoopsAnalysis() + module SpillCostsAnalysis = MakeSpillCostsAnalysis() + module RegistersDescription = (val regdescr : Ir_arch.REGISTERS_DESCRIPTION) + module ConstantFoldingAnalysis = MakeConstantFoldingAnalysis() + module InterferenceGraphAnalysis = MakeInterferenceGraphAnalysis() + module Spilling = MakeSpilling() + module ReachabilityAnalysis = MakeReachabilityAnalysis() + end in + (module M : Iface.COMPILER_TOOLBOX) + +let resolve_compiler_steps regdescr = + let module CompilerToolbox = (val resolve_compiler_toolbox regdescr : Iface.COMPILER_TOOLBOX) in + let module LexerAndParser = (val Resolver.lexer_and_parser !register) in + let module MakeTypechecker = (val Resolver.make_typechecker !register) in + let module MakeTranslator = (val Resolver.make_translator !register) in + let module MakeJumpThreading = (val Resolver.make_jump_threading !register) in + let module MakeConstantFolding = (val Resolver.make_constant_folding !register) in + let module MakeHiLower = (val Resolver.make_hilower !register) in + let module MakeCallConv = (val Resolver.make_callconv !register) in + let module MakeMipsLower = (val Resolver.make_mipslower !register) in + let module MakeRegisterAllocator = (val Resolver.make_register_allocator !register) in + let module MakeDeadCodeElimination = (val Resolver.make_dead_code_elimination !register) in + let module MakeCodegen = (val Resolver.make_codegen !register) in + + let module Steps = struct + module Toolbox = CompilerToolbox + module LexerAndParser = LexerAndParser + module Typechecker = MakeTypechecker() + module Translator = MakeTranslator() + module JumpThreading = MakeJumpThreading() + module HiLower = MakeHiLower(CompilerToolbox) + module CallConv = MakeCallConv(CompilerToolbox) + module MipsLower = MakeMipsLower(CompilerToolbox) + module RegisterAllocator = MakeRegisterAllocator(CompilerToolbox) + module ConstantFolding = MakeConstantFolding(CompilerToolbox) + module DeadCodeElimination = MakeDeadCodeElimination(CompilerToolbox) + module Codegen = MakeCodegen(CompilerToolbox) + end in + + (module Steps : Iface.COMPILER_STEPS) + +let load_plugin path = + try + Plugin_register.current_file := Filename.basename path; + Dynlink.loadfile path; + Plugin_register.current_file := ""; + with Dynlink.Error e -> + failwith @@ Format.sprintf "Cannot load plugin '%s': %s" path (Dynlink.error_message e) \ No newline at end of file diff --git a/source/xi/xi.ml b/source/xi/xi.ml new file mode 100644 index 0000000..86a23f1 --- /dev/null +++ b/source/xi/xi.ml @@ -0,0 +1,82 @@ +open Xi_lib + + +module CommandLine = struct + open Cmdliner + + let compile xi_log extra_debug mod_uwr plugin reg_descr stop_after output source = + Logger.init xi_log; + Logger.set_extra_debug extra_debug; + Plugin_manager.load_plugin mod_uwr; + let reg_descr = match List.assoc_opt reg_descr Ir_arch.descriptions with + | Some reg_descr -> reg_descr + | None -> failwith "Unknown registers description" + in + begin match plugin with + | Some path -> + Plugin_manager.load_plugin path + | None -> + () + end; + let module Steps = (val Plugin_manager.resolve_compiler_steps reg_descr) in + let module Params = struct + let output = output + let stop_point = match stop_after with + | Some s -> s + | None -> "" + end in + let module Pipeline = Pipeline.Make(Steps)(Params) in + match Pipeline.compile source with + | Ok () -> + 0 + | Error xs -> + Format.eprintf "Failed: %s\n%!" xs; + 1 + + let stop_after = + let doc = "Stops compiler after given phase" in + Arg.(value & opt (some string) None & info ["stop-after"] ~doc) + + let mod_uwr = + let doc = "Base module" in + Arg.(value & opt string "xisdk/mod_uwr.cma" & info ["mod-uwr"] ~doc) + + let reg_descr = + let doc = "EXPERIMENTAL: Registers description (see Ir_arch.descriptions)" in + Arg.(value & opt string "normal" & info ["registers-description"] ~doc) + + let plugin = + let doc = "Plugin module" in + Arg.(value & opt (some string) None & info ["plugin"] ~doc) + + let output = + let doc = "Output file" in + Arg.(value & opt string "main.s" & info ["o"; "output"] ~doc) + + let xi_log = + let doc = "Log directory" in + Arg.(value & opt string "xilog" & info ["xi-log"] ~doc) + + let runtime = + let doc = "Runtime" in + Arg.(value & opt file "xisdk/runtime.s" & info ["runtime"] ~doc) + + let extra_debug = + let doc = "Enables extra debug" in + Arg.(value & flag & info ["extra-debug"] ~doc) + + let source_file = + let doc = "Xi Source File" in + Arg.(required & pos 0 (some file) None & info [] ~doc) + + + let cmd = + let doc = "Compile Xi Program" in + let version = "pracownia1.1-0-gc10b4f2" in + Term.(const compile $ xi_log $ extra_debug $ mod_uwr $ plugin $ reg_descr $ stop_after $ output $ source_file), + Term.info "xi" ~doc ~version + + + let () = Term.(exit_status @@ eval cmd) + +end 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.ml b/source/xi_lib/analysis.ml new file mode 100644 index 0000000..ac15cb5 --- /dev/null +++ b/source/xi_lib/analysis.ml @@ -0,0 +1,77 @@ +module Knowledge = struct + + type 'a t = + { pre: 'a + ; post: 'a + } + + let pre t = t.pre + + let post t = t.post + + let alter ?pre ?post t = + let t = match pre with + | Some pre -> {t with pre = pre} + | None -> t + in + let t = match post with + | Some post -> {t with post = post} + | None -> t + in + t + + let make pre post : 'a t = {pre; post} + + type 'a table = (Ir.label, 'a t) Hashtbl.t + +end + +module BlockKnowledge = struct + + type 'a t = + | Simple of 'a Knowledge.t + | Complex of + { block: 'a Knowledge.t + ; body: ('a Knowledge.t * Ir.instr) list + ; terminator: 'a Knowledge.t * Ir.terminator + } + + let block = function + | Simple t -> t + | Complex {block; _} -> block + + let pre t = Knowledge.pre @@ block t + let post t = Knowledge.post @@ block t + + let terminator = function + | Simple _ -> failwith "BlockKnowledge.terminator" + | Complex t-> t.terminator + + let body = function + | Simple _ -> failwith "BlockKnowledge.body" + | Complex t -> t.body + + let terminator_instr t = snd @@ terminator t + + let terminator_kw t = fst @@ terminator t + + let make_complex ~block ~body ~terminator = + Complex { block; body; terminator } + + let make_simple t = Simple t + + type 'a table = (Ir.label, 'a t) Hashtbl.t + + let alter_prepost ?pre ?post = function + | Simple t -> + Simple (Knowledge.alter ?pre ?post t) + + | Complex {block; body; terminator} -> + let block = Knowledge.alter ?pre ?post block in + Complex {block; body; terminator} + + let is_complex = function + | Complex _ -> true + | Simple _ -> false + +end diff --git a/source/xi_lib/analysis_domain.ml b/source/xi_lib/analysis_domain.ml new file mode 100644 index 0000000..9f49a3e --- /dev/null +++ b/source/xi_lib/analysis_domain.ml @@ -0,0 +1,135 @@ + +module MapWithTop(M:Map.S) = struct + + type 'v t = + | Top + | Map of 'v M.t + + let equal a b = match a,b with + | Top, Top -> + true + | Top, _ + | _, Top -> + false + | Map a, Map b -> + M.equal (=) a b + + let less_or_equal a b = match a,b with + | _, Top -> + true + + | Top, _ -> + false + + | Map a, Map b -> + let check (k, v) = + match M.find_opt k b with + | Some v' -> v = v' + | None -> false + in + let a_items = M.to_seq a in + let checks = Seq.map check a_items in + Seq.fold_left (&&) true checks + + let greater_or_equal a b = less_or_equal b a + + let unhask dfl = function + | Top -> dfl + | Map m -> m + +end + +module SetWithTop(M:Set.S) = struct + + type t = + | Top + | Set of M.t + + let equal a b = match a,b with + | Top, Top -> + true + | Top, _ + | _, Top -> + false + | Set a, Set b -> + M.equal a b + + let less_or_equal a b = match a,b with + | _, Top -> + true + + | Top, _ -> + false + + | Set a, Set b -> + M.subset a b + + let greater_or_equal a b = less_or_equal b a + + let unhask dfl = function + | Top -> dfl + | Set m -> m + +end + + +module LiveVariables = struct + + type domain = Ir.RegSet.t + + type table = domain Analysis.BlockKnowledge.table + + type block_knowledge = domain Analysis.BlockKnowledge.t + + let string_of_domain x = Ir_utils.string_of_reglist @@ List.of_seq @@ Ir.RegSet.to_seq x +end + +module InterferenceGraph = struct + + type graph = Ir.RegGraph.t + +end + +module ConstantFolding = struct + + type domain = Ir.expr option Ir.RegMap.t + + type table = domain Analysis.BlockKnowledge.table + + type block_knowledge = domain Analysis.BlockKnowledge.t + + let string_of_el = function + | None -> "T" + | 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 seq = Ir.RegMap.to_seq dom in + let seq = Seq.map f seq in + String.concat " " @@ List.of_seq seq + +end + +module DominatorsAnalysis = struct + + module D = SetWithTop(Ir.LabelSet) + + type t = D.t + + type table = t Analysis.BlockKnowledge.table + + let unhask = D.unhask Ir.LabelSet.empty + +end + +module NaturalLoops = struct + + type table = (Ir.label, Ir.LabelSet.t) Hashtbl.t + +end + +module ReachabilityAnalysis = struct + + type table = Ir.LabelSet.t Analysis.BlockKnowledge.table + +end \ No newline at end of file diff --git a/source/xi_lib/analysis_visualizer.ml b/source/xi_lib/analysis_visualizer.ml new file mode 100644 index 0000000..6c8ccf3 --- /dev/null +++ b/source/xi_lib/analysis_visualizer.ml @@ -0,0 +1,295 @@ +open Ir +open Ir_utils +open Analysis + +module type DOMAIN = sig + + type domain + + val string_of_domain: domain -> string + +end + +module type DOMAIN_AND_BLOCK_ANALYSIS = sig + + include DOMAIN + + + val analyse_block: ControlFlowGraph.t -> domain Knowledge.table -> label -> domain BlockKnowledge.t + +end + +(* +module TableVisualizer = struct + + let stringize_table (to_string: 'a -> string) result = + let new_result = Hashtbl.create 513 in + let f k v = + let kw = Knowledge.make (to_string @@ Knowledge.pre v) (to_string @@ Knowledge.post v) in + Hashtbl.replace new_result k kw + in + Hashtbl.iter f result; + new_result + + let stringize_full_table (to_string: 'a -> string) result = + let visualize_kw v = Knowledge.make (to_string @@ Knowledge.pre v) (to_string @@ Knowledge.post v) in + let visualize_instr (kw, instr) = (visualize_kw kw, instr) in + let visualize_body = List.map visualize_instr in + let visualize_terminator (kw, terminator) = (visualize_kw kw, terminator) in + let new_result = Hashtbl.create 513 in + let f k v = + let pre = to_string @@ BlockKnowledge.pre v in + let post = to_string @@ BlockKnowledge.post v in + let body = visualize_body @@ BlockKnowledge.body v in + let terminator = visualize_terminator @@ BlockKnowledge.terminator v in + Hashtbl.replace new_result k @@ BlockKnowledge.make ~pre ~post ~body ~terminator + in + Hashtbl.iter f result; + new_result + + +end +*) + +module NgMakeGraphvizVisualizer(D:DOMAIN) = struct + + let visualise_instr (pre, post, instr) = + let instr = string_of_instr instr in + String.concat "\n" + [ + Format.sprintf "<tr><td>%s</td><td align='left'><b>%s</b></td><td>%s</td></tr>" pre instr post + ] + + let visualise_terminator (pre, post, t) = + let t = string_of_terminator t in + String.concat "\n" + [ + Format.sprintf "<tr><td>%s</td><td bgcolor='green' ><b>%s</b></td><td>%s</td></tr>" pre t post + ] + + let block_template_pre pre name = + [ Format.sprintf "<table cellspacing='0' cellborder='1' align='left' border='0'>" + ; Format.sprintf "<tr><td colspan='3' port='e' bgcolor='yellow'><b>%s</b></td></tr>" name + ; Format.sprintf "<tr><td colspan='3'>%s</td></tr>" @@ pre + ] + + let block_template_post post = + [ Format.sprintf "<tr><td colspan='3' port='x'>%s</td></tr>" post + ; Format.sprintf "</table>" + ] + + let block_template name pre post body = + String.concat "" @@ List.flatten + [ block_template_pre pre name + ; body + ; block_template_post post + ] + + let stringize_body body = + let f (kw, instr) = + let pre = D.string_of_domain @@ Knowledge.pre kw in + let post = D.string_of_domain @@ Knowledge.post kw in + (pre, post, instr) + in + List.map f body + + let artificial_body body = + let f instr = + ("", "", instr) + in + List.map f body + + + let stringize_terminator (kw, terminator) = + let pre = D.string_of_domain @@ Knowledge.pre kw in + let post = D.string_of_domain @@ Knowledge.post kw in + (pre, post, terminator) + + let artificial_terminator terminator = + ("", "", terminator) + + let prepare_block bb_kw body terminator = + if BlockKnowledge.is_complex bb_kw then + let sbody = stringize_body @@ BlockKnowledge.body bb_kw in + let sterm = stringize_terminator @@ BlockKnowledge.terminator bb_kw in + sbody, sterm + else + let sbody = artificial_body body in + let sterm = artificial_terminator terminator in + sbody, sterm + + let compute_block_label cfg table v = + let v_str = string_of_label v in + let kw = Hashtbl.find table v in + let pre = D.string_of_domain @@ BlockKnowledge.pre kw in + let post = D.string_of_domain @@ BlockKnowledge.post kw in + if v = ControlFlowGraph.entry_label cfg then + block_template (Format.sprintf "ENTRY %s" v_str) pre post [] + else if v = ControlFlowGraph.exit_label cfg then + block_template (Format.sprintf "EXIT %s" v_str) pre post [] + else + let body = ControlFlowGraph.block cfg v in + let terminator = ControlFlowGraph.terminator cfg v in + let sbody, sterm = prepare_block kw body terminator in + let body = List.flatten + [ List.map visualise_instr sbody + ; [visualise_terminator sterm] + ] in + block_template (Format.sprintf "BLOCK %s" v_str) pre post body + + + let describe_vertex cfg table v = + Format.sprintf "N%s[shape=none, margin=0, label=<%s>];" + (string_of_label v) + (compute_block_label cfg table v) + + let describe_outedges cfg v = + let describe_edge w = + Format.sprintf "N%s:x -> N%s:e;" (string_of_label v) (string_of_label w) + in + String.concat "\n" @@ List.map describe_edge @@ ControlFlowGraph.successors cfg v + + let visualize cfg table = + let labels = ControlFlowGraph.labels cfg in + let vertices = String.concat "\n" @@ List.map (describe_vertex cfg table) labels in + let edges = String.concat "\n" @@ List.map (describe_outedges cfg) labels in + String.concat "\n" + [ "digraph CFG {" + ; "node [shape=none; fontname=\"Courier\" fontsize=\"9\"];" + ; "ordering=out;" + ; vertices + ; edges + ; "}" + ] + +end + +module MakeGraphvizVisualizer(D:DOMAIN_AND_BLOCK_ANALYSIS) = struct + + let visualise_instr (kw, instr) = + let pre = D.string_of_domain @@ Knowledge.pre kw in + let post = D.string_of_domain @@ Knowledge.post kw in + let instr = string_of_instr instr in + String.concat "\n" + [ + Format.sprintf "<tr><td>%s</td><td align='left'><b>%s</b></td><td>%s</td></tr>" pre instr post + ] + + let visualise_terminator (kw, t) = + let pre = D.string_of_domain @@ Knowledge.pre kw in + let post = D.string_of_domain @@ Knowledge.post kw in + let t = string_of_terminator t in + String.concat "\n" + [ + Format.sprintf "<tr><td>%s</td><td bgcolor='green' ><b>%s</b></td><td>%s</td></tr>" pre t post + ] + + let block_template_pre pre name = + [ Format.sprintf "<table cellspacing='0' cellborder='1' align='left' border='0'>" + ; Format.sprintf "<tr><td colspan='3' port='e' bgcolor='yellow'><b>%s</b></td></tr>" name + ; Format.sprintf "<tr><td colspan='3'>%s</td></tr>" @@ pre + ] + + let block_template_post post = + [ Format.sprintf "<tr><td colspan='3' port='x'>%s</td></tr>" post + ; Format.sprintf "</table>" + ] + + let block_template name pre post body = + String.concat "" @@ List.flatten + [ block_template_pre pre name + ; body + ; block_template_post post + ] + + let compute_block_label cfg table v = + let v_str = string_of_label v in + let kw = Hashtbl.find table v in + let pre = D.string_of_domain @@ Knowledge.pre kw in + let post = D.string_of_domain @@ Knowledge.post kw in + if v = ControlFlowGraph.entry_label cfg then + block_template (Format.sprintf "ENTRY %s" v_str) pre post [] + else if v = ControlFlowGraph.exit_label cfg then + block_template (Format.sprintf "EXIT %s" v_str) pre post [] + else + let bb_kw = D.analyse_block cfg table v in + let body = List.flatten + [ List.map visualise_instr (BlockKnowledge.body bb_kw) + ; [visualise_terminator (BlockKnowledge.terminator bb_kw)] + ] in + block_template (Format.sprintf "BLOCK %s" v_str) pre post body + + + let describe_vertex cfg table v = + Format.sprintf "N%s[shape=none, margin=0, label=<%s>];" + (string_of_label v) + (compute_block_label cfg table v) + + let describe_outedges cfg v = + let describe_edge w = + Format.sprintf "N%s:x -> N%s:e;" (string_of_label v) (string_of_label w) + in + String.concat "\n" @@ List.map describe_edge @@ ControlFlowGraph.successors cfg v + + let visualize cfg table = + let labels = ControlFlowGraph.labels cfg in + let vertices = String.concat "\n" @@ List.map (describe_vertex cfg table) labels in + let edges = String.concat "\n" @@ List.map (describe_outedges cfg) labels in + String.concat "\n" + [ "digraph CFG {" + ; "node [shape=none; fontname=\"Courier\" fontsize=\"9\"];" + ; "ordering=out;" + ; vertices + ; edges + ; "}" + ] + +end + +module VisualiseRegGraph = struct + + let reg_to_name = function + | REG_Hard i -> Format.sprintf "H%u" i + | REG_Tmp i -> Format.sprintf "T%u" i + | REG_Spec i -> Format.sprintf "S%u" i + + let describe_vertex v = + Format.sprintf "%s[label=\"%s\"];" (reg_to_name v) (string_of_reg v) + + let describe_edge a b = + Format.sprintf "%s -- %s;" (reg_to_name a) (reg_to_name b) + + let describe_vertices graph = + String.concat "\n" @@ RegGraph.fold_vertex (fun r xs -> describe_vertex r :: xs) graph [] + + let describe_edges graph = + String.concat "\n" @@ RegGraph.fold_edges (fun a b xs -> describe_edge a b :: xs) graph [] + + let visualise_graph reggraph = + String.concat "\n" + [ "graph INF {" + ; "layout=circo;" + ; describe_vertices reggraph + ; describe_edges reggraph + ; "}" + ] + +end + +module Lva_Graphviz = NgMakeGraphvizVisualizer(struct + type domain = Analysis_domain.LiveVariables.domain + let string_of_domain = Analysis_domain.LiveVariables.string_of_domain +end) + +module Cfa_Graphviz = NgMakeGraphvizVisualizer(struct + type domain = Analysis_domain.ConstantFolding.domain + let string_of_domain = Analysis_domain.ConstantFolding.string_of_domain +end) + +let visualize_live_variables = Lva_Graphviz.visualize + + +let visualize_interference_graph = VisualiseRegGraph.visualise_graph + + +let visualize_constant_folding = Cfa_Graphviz.visualize diff --git a/source/xi_lib/ast.ml b/source/xi_lib/ast.ml new file mode 100644 index 0000000..3123af7 --- /dev/null +++ b/source/xi_lib/ast.ml @@ -0,0 +1,288 @@ + +type location = Location of { line: int; column: int; file: string } + +let string_of_location (Location {line;column;file}) = + Format.sprintf "%s:%u:%u" file line column + +type identifier + = Identifier of string + +let string_of_identifier (Identifier i) = i + +type node_tag = + NodeTag of int + +let string_of_node_tag (NodeTag i) = + Format.sprintf "%%node%i" i + +type binop = + | BINOP_And + | BINOP_Or + | BINOP_Add + | BINOP_Sub + | BINOP_Mult + | BINOP_Div + | BINOP_Rem + +let string_of_binop = function + | BINOP_And -> "&" + | BINOP_Or -> "|" + | BINOP_Add -> "+" + | BINOP_Sub -> "-" + | BINOP_Mult -> "*" + | BINOP_Div -> "/" + | BINOP_Rem -> "%" + +type relop = + | RELOP_Eq + | RELOP_Ne + | RELOP_Lt + | RELOP_Gt + | RELOP_Le + | RELOP_Ge + +let string_of_relop = function + | RELOP_Eq -> "==" + | RELOP_Ne -> "!=" + | RELOP_Lt -> "<" + | RELOP_Gt -> ">" + | RELOP_Ge -> ">=" + | RELOP_Le -> "<=" + +type unop = + | UNOP_Not + | UNOP_Neg + +type type_expression = + | TEXPR_Int of + { loc:location + } + + | TEXPR_Bool of + { loc:location + } + + | TEXPR_Array of + { loc:location + ; sub:type_expression + ; dim:expression option + } + +and expression = + | EXPR_Id of + { tag:node_tag + ; loc:location + ; id:identifier + } + + | EXPR_Int of + { tag:node_tag + ; loc:location + ; value:Int32.t + } + + | EXPR_Char of + { tag:node_tag + ; loc:location + ; value:Char.t + } + + | EXPR_String of + { tag:node_tag + ; loc:location + ; value:string + } + + | EXPR_Bool of + { tag:node_tag + ; loc:location + ; value:bool + } + + | EXPR_Relation of + { tag:node_tag + ; loc:location + ; op:relop + ; lhs:expression + ; rhs:expression + } + + | EXPR_Binop of + { tag:node_tag + ; loc:location + ; op:binop + ; lhs:expression + ; rhs:expression + } + + | EXPR_Length of + { tag:node_tag + ; loc:location + ; arg:expression + } + + | EXPR_Unop of + { tag:node_tag + ; loc:location + ; op:unop + ; sub:expression + } + + | EXPR_Call of + call + + | EXPR_Index of + { tag:node_tag + ; loc:location + ; expr:expression + ; index:expression + } + + | EXPR_Struct of + { tag:node_tag + ; loc:location + ; elements: expression list + } + +and call = + | Call of + { tag:node_tag + ; loc:location + ; callee:identifier + ; arguments:expression list + } + + +let location_of_expression = function + | EXPR_Id {loc; _} -> loc + | EXPR_Struct {loc; _} -> loc + | EXPR_Index {loc; _} -> loc + | EXPR_Call (Call {loc; _}) -> loc + | EXPR_Unop {loc; _} -> loc + | EXPR_Binop {loc; _} -> loc + | EXPR_Relation {loc; _} -> loc + | EXPR_Length {loc; _} -> loc + | EXPR_Int {loc; _} -> loc + | EXPR_Char {loc; _} -> loc + | EXPR_Bool {loc; _} -> loc + | EXPR_String {loc; _} -> loc + +let tag_of_expression = function + | EXPR_Id {tag; _} -> tag + | EXPR_Struct {tag; _} -> tag + | EXPR_Index {tag; _} -> tag + | EXPR_Call (Call {tag; _}) -> tag + | EXPR_Unop {tag; _} -> tag + | EXPR_Binop {tag; _} -> tag + | EXPR_Relation {tag; _} -> tag + | EXPR_Length {tag; _} -> tag + | EXPR_Int {tag; _} -> tag + | EXPR_Char {tag; _} -> tag + | EXPR_Bool {tag; _} -> tag + | EXPR_String {tag; _} -> tag + +let location_of_call (Call {loc; _}) = loc + +let identifier_of_call (Call {callee; _}) = callee + +type var_declaration = + | VarDecl of + { loc:location + ; id:identifier + ; tp:type_expression + } + +let location_of_var_declaration (VarDecl {loc; _}) = loc +let identifier_of_var_declaration (VarDecl {id; _}) = id +let type_expression_of_var_declaration (VarDecl {tp; _}) = tp + +module IdMap = Map.Make(struct + type t = identifier + + let compare = compare + end) + +type lvalue = + | LVALUE_Id of + { loc:location + ; id:identifier + } + + | LVALUE_Index of + { loc:location + ; sub:expression + ; index:expression + } + +type statement = + | STMT_Call of + call + + | STMT_Assign of + { loc:location + ; lhs:lvalue + ; rhs:expression + } + + | STMT_VarDecl of + { var:var_declaration + ; init:expression option + } + + | STMT_If of + { loc:location + ; cond:expression + ; then_branch: statement + ; else_branch: statement option + } + + | STMT_While of + { loc:location + ; cond:expression + ; body: statement + } + + | STMT_Return of + { loc:location + ; values:expression list + } + + | STMT_MultiVarDecl of + { loc:location + ; vars:var_declaration option list + ; init:call + } + + | STMT_Block of + statement_block + +and statement_block = + | STMTBlock of + { loc:location + ; body: statement list + } + +let location_of_block (STMTBlock {loc; _}) = loc + +let location_of_statement = function + | STMT_Assign {loc; _} -> loc + | STMT_While {loc; _} -> loc + | STMT_Call call -> location_of_call call + | STMT_Block block -> location_of_block block + | STMT_Return {loc; _} -> loc + | STMT_VarDecl {var; _} -> location_of_var_declaration var + | STMT_MultiVarDecl {loc; _} -> loc + | STMT_If {loc; _} -> loc + +type global_declaration = + | GDECL_Function of + { loc:location + ; id:identifier + ; formal_parameters:var_declaration list + ; return_types:type_expression list + ; body:statement_block option + } + +type module_definition = ModuleDefinition of + { global_declarations: global_declaration list + } diff --git a/source/xi_lib/ast_printer.ml b/source/xi_lib/ast_printer.ml new file mode 100644 index 0000000..67b4dd5 --- /dev/null +++ b/source/xi_lib/ast_printer.ml @@ -0,0 +1,271 @@ +open Ast + + +let string_of_binop = function + | BINOP_And -> "&" + | BINOP_Or -> "|" + | BINOP_Add -> "+" + | BINOP_Sub -> "-" + | BINOP_Mult -> "*" + | BINOP_Div -> "/" + | BINOP_Rem -> "%" + +let string_of_relop = function + | RELOP_Eq -> "==" + | RELOP_Ne -> "!=" + | RELOP_Lt -> "<" + | RELOP_Gt -> ">" + | RELOP_Le -> "<=" + | RELOP_Ge -> ">=" + +let string_of_unop = function + | UNOP_Not -> "!" + | UNOP_Neg -> "-" + +let indent x = " " ^ x + +let indentxs = List.map indent + +let rec show_expression = function + | EXPR_Id {id; _} -> + string_of_identifier id + + + | EXPR_Int {value; _} -> + Int32.to_string value + + | EXPR_Char {value; _} -> + Format.sprintf "%c" value + + | EXPR_String {value; _} -> + value + + | EXPR_Bool {value; _} -> + string_of_bool value + + | EXPR_Binop {op; lhs; rhs; _} -> + String.concat "" + [ "(" + ; show_expression lhs + ; " " + ; string_of_binop op + ; " " + ; show_expression rhs + ; ")" + ] + + | EXPR_Relation {op; lhs; rhs; _} -> + String.concat "" + [ "(" + ; show_expression lhs + ; " " + ; string_of_relop op + ; " " + ; show_expression rhs + ; ")" + ] + + | EXPR_Length {arg; _} -> + String.concat "" + [ "length(" + ; show_expression arg + ; ")" + ] + + | EXPR_Unop {op; sub; _} -> + String.concat "" + [ string_of_unop op + ; show_expression sub + ] + + | EXPR_Call call -> + show_call call + + | EXPR_Index {expr; index; _} -> + String.concat "" + [ show_expression expr + ; "[" + ; show_expression index + ; "]" + ] + + | EXPR_Struct {elements; _} -> + String.concat "" + [ "{" + ; String.concat ", " (List.map show_expression elements) + ; "}" + ] + +and show_call (Call {callee; arguments; _}) = + String.concat "" + [ string_of_identifier callee + ; "(" + ; String.concat ", " (List.map show_expression arguments) + ; ")" + ] + +let rec show_type_expression = function + | TEXPR_Int _ -> + "int" + + | TEXPR_Bool _ -> + "bool" + + | TEXPR_Array {sub;dim;_} -> + String.concat "" + [ show_type_expression sub + ; "[" + ; (match dim with | None -> "" | Some e -> show_expression e) + ; "]" + ] + +let show_var_declaration (VarDecl {id; tp; _}) = + String.concat "" + [ string_of_identifier id + ; ":" + ; show_type_expression tp + ] + +let show_var_declaration_opt = function + | Some v -> show_var_declaration v + | None -> "_" + +let show_lvalue = function + | LVALUE_Id {id; _} -> + string_of_identifier id + | LVALUE_Index {sub; index; _} -> + String.concat "" + [ show_expression sub + ; "[" + ; show_expression index + ; "]" + ] + + +let rec showxs_statement = function + | STMT_Call call -> + [ show_call call + ] + + | STMT_VarDecl {var; init=None} -> + [ show_var_declaration var + ] + + | STMT_VarDecl {var; init=Some v} -> + [ String.concat " " + [ show_var_declaration var + ; "=" + ; show_expression v + ] + ] + + | STMT_Return {values; _} -> + [ String.concat " " + [ "return" + ; String.concat ", " (List.map show_expression values) + ] + ] + + | STMT_Block blok -> + showxs_block blok + + | STMT_While {cond; body; _} -> + List.concat + [ [ String.concat " " + [ "while" + ; "(" + ; show_expression cond + ; ")" + ] ] + ; showxs_statement_as_block body + ] + + | STMT_If {cond; then_branch; else_branch=None; _} -> + List.concat + [ [ String.concat " " + [ "if" + ; "(" + ; show_expression cond + ; ")" + ] ] + ; showxs_statement_as_block then_branch + ] + + | STMT_If {cond; then_branch; else_branch=Some else_branch; _} -> + List.concat + [ [ String.concat " " + [ "if" + ; "(" + ; show_expression cond + ; ")" + ] ] + ; showxs_statement_as_block then_branch + ; [ "else" ] + ; showxs_statement_as_block else_branch + ] + | STMT_Assign {lhs; rhs; _} -> + [ String.concat " " + [ show_lvalue lhs + ; "=" + ; show_expression rhs + ] + ] + | STMT_MultiVarDecl {vars; init; _} -> + [ String.concat " " + [ String.concat ", " (List.map show_var_declaration_opt vars) + ; "=" + ; show_call init + ] + ] + +and showxs_block = function + | STMTBlock {body; _} -> + List.concat + [ ["{"] + ; indentxs @@ List.concat @@ List.map showxs_statement body + ; ["}"] + ] + +and showxs_statement_as_block = function + | STMT_Block blok -> + showxs_block blok + | s -> + List.concat + [ ["{"] + ; indentxs @@ showxs_statement s + ; ["}"] + ] + +let show_formal_parameters params = + String.concat ", " @@ List.map show_var_declaration params + + +let show_return_types = function + | [] -> + "" + | return_types -> + ": " ^ String.concat ", " (List.map show_type_expression return_types) + +let showxs_global_declaration = function + | GDECL_Function {id; body; formal_parameters; return_types; _} -> + List.concat + [ [ String.concat "" + [ string_of_identifier id + ; "(" + ; show_formal_parameters formal_parameters + ; ")" + ; show_return_types return_types + ] ] + ; match body with + | Some body -> showxs_block body + | None -> [] + ] + +let showxs_module_definition (ModuleDefinition {global_declarations; _}) = + let f x = + showxs_global_declaration x @ [""] + in + List.flatten (List.map f global_declarations) + +let show_module_definition m = + String.concat "\n" @@ showxs_module_definition m \ No newline at end of file diff --git a/source/xi_lib/ast_rawprinter.ml b/source/xi_lib/ast_rawprinter.ml new file mode 100644 index 0000000..0c6494e --- /dev/null +++ b/source/xi_lib/ast_rawprinter.ml @@ -0,0 +1,313 @@ +open Ast + + +let string_of_binop = function + | BINOP_And -> "BINOP_And" + | BINOP_Or -> "BINOP_Or" + | BINOP_Add -> "BINOP_Add" + | BINOP_Sub -> "BINOP_Sub" + | BINOP_Mult -> "BINOP_Mult" + | BINOP_Div -> "BINOP_Div" + | BINOP_Rem -> "BINOP_Rem" + +let string_of_relop = function + | RELOP_Eq -> "RELOP_Eq" + | RELOP_Ne -> "RELOP_Ne" + | RELOP_Lt -> "RELOP_Lt" + | RELOP_Gt -> "RELOP_Gt" + | RELOP_Le -> "RELOP_Le" + | RELOP_Ge -> "RELOP_Ge" + +let string_of_unop = function + | UNOP_Not -> "UNOP_Not" + | UNOP_Neg -> "UNOP_Neg" + +let indent x = " " ^ x +let indentfmt fmt = + let cont = Format.sprintf " %s" in + Format.ksprintf cont fmt + +let indentxs = List.map indent + +type p = + | P_String of string + | P_Sequence of p list + | P_List of p list + | P_Dict of string * (string * p) list + +type r = + | R_String of string + | R_Indent of r + | R_Break + | R_Tab + | R_Group of r list + +let render_r = function + | R_String s -> s + | R_Tab -> " " + | R_Break -> "\n" + | R_Group _ -> failwith "R_Group should be eliminated" + | R_Indent _ -> failwith "R_Indent should be eliminated" + +let rec insert_tabs tabs = function + | R_Indent r -> + insert_tabs (R_Tab::tabs) r + | R_Break -> + R_Group [R_Break; R_Group tabs] + | R_Group rs -> + R_Group (List.map (insert_tabs tabs) rs) + | r -> + r + +let rec flatten = function + | R_Indent _ -> failwith "R_Indent should be eliminated" + | R_Group xs -> List.concat @@ List.map flatten xs + | r -> [r] + +let render_r r = + String.concat "" @@ List.map render_r @@ flatten @@ insert_tabs [] r + +let rec render_p = function + | P_String s -> + R_String s + | P_List xs -> + let rec f acc = function + | [] -> + R_Group (List.rev acc) + + | x::xs -> + let entry = R_Group [render_p x; R_String ";"; R_Break] in + f (entry::acc) xs + in + R_Group + [ R_String "[" + ; R_Indent (R_Group [R_Break; f [] xs]) + ; R_String "]" + ] + + | P_Dict (kind, items) -> + let rec f acc = function + | [] -> + R_Group (List.rev acc) + | (k,v)::xs -> + let entry = R_Group [R_String k; R_String " = "; R_Indent (render_p v); R_String ";"; R_Break] in + f (entry::acc) xs + in + R_Group + [ R_String kind + ; R_String " " + ; R_String "{" + ; R_Indent (R_Group [R_Break; f [] items]) + ; R_String "}" + ] + + | P_Sequence xs -> + R_Group (List.map render_p xs) + +let p_dict k items = P_Dict (k,items) + +let p_identifier id = P_String (Format.sprintf "\"%s\"" @@ string_of_identifier id) +let p_string id = P_String (Format.sprintf "\"%s\"" id) +let p_location loc = P_String (string_of_location loc) +let p_node_tag tag = P_String (string_of_node_tag tag) +let p_i32 i = P_String (Int32.to_string i) +let p_char c = P_String (Format.sprintf "'%c'" c) +let p_bool b = P_String (string_of_bool b) + +let p_opt f = function + | None -> P_String "None" + | Some x -> P_Sequence [P_String "Some "; f x] + + +let rec p_expression = function + | EXPR_Id {loc; tag; id} -> p_dict "EXPR_Id" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "id", p_identifier id + ] + + | EXPR_Int {tag; loc; value} -> p_dict "EXPR_Int" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "value", p_i32 value + ] + + | EXPR_Char {tag; loc; value} -> p_dict "EXPR_Char" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "value", p_char value + ] + + | EXPR_String {tag; loc; value} -> p_dict "EXPR_String" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "value", p_string value + ] + + | EXPR_Bool {tag; loc; value} -> p_dict "EXPR_Bool" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "value", p_bool value + ] + + | EXPR_Relation {tag; loc; op; lhs; rhs} -> p_dict "EXPR_Relation" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "op", P_String (string_of_relop op) + ; "lhs", p_expression lhs + ; "rhs", p_expression rhs + ] + + | EXPR_Binop {tag; loc; op; lhs; rhs} -> p_dict "EXPR_Binop" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "op", P_String (string_of_binop op) + ; "lhs", p_expression lhs + ; "rhs", p_expression rhs + ] + + | EXPR_Unop {tag; loc; op; sub} -> p_dict "EXPR_Unop" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "op", P_String (string_of_unop op) + ; "sub", p_expression sub + ] + + | EXPR_Length {tag; loc; arg} -> p_dict "EXPR_Length" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "arg", p_expression arg + ] + + | EXPR_Index {tag; loc; expr; index} -> p_dict "EXPR_Length" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "expr", p_expression expr + ; "index", p_expression index + ] + + | EXPR_Struct {tag; loc; elements} -> p_dict "EXPR_Struct" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "elements", P_List (List.map p_expression elements) + ] + + | EXPR_Call call -> P_Sequence + [ P_String "EXPR_Call " + ; p_call call + ] + +and p_call = function + | Call {tag; loc; callee; arguments} -> p_dict "Call" + [ "loc", p_location loc + ; "tag", p_node_tag tag + ; "callee", p_identifier callee + ; "arguments", P_List (List.map p_expression arguments) + ] + +let rec p_type_expression = function + | TEXPR_Int {loc} -> p_dict "TEXPR_Int" + [ "loc", p_location loc + ] + + | TEXPR_Bool {loc} -> p_dict "TEXPR_Bool" + [ "loc", p_location loc + ] + + | TEXPR_Array {loc;sub;dim} -> p_dict "TPEXPR_Array" + [ "loc", p_location loc + ; "sub", p_type_expression sub + ; "dim", p_opt p_expression dim + ] + +let p_lvalue = function + | LVALUE_Id {loc; id} -> p_dict "LVALUE_Id" + [ "loc", p_location loc + ; "id", p_identifier id + ] + | LVALUE_Index {loc; sub; index} -> p_dict "LVALUE_Index" + [ "loc", p_location loc + ; "sub", p_expression sub + ; "index", p_expression index + ] + +let p_var_declaration = function + | VarDecl {loc;id;tp} -> p_dict "VarDecl" + [ "loc", p_location loc + ; "id", p_identifier id + ; "tp", p_type_expression tp + ] + +let rec p_statement = function + | STMT_Call call -> P_Sequence + [ P_String "STMT_Call " + ; p_call call + ] + + | STMT_Assign {loc; lhs; rhs} -> p_dict "STMT_Assign" + [ "loc", p_location loc + ; "lhs", p_lvalue lhs + ; "rhs", p_expression rhs + ] + + | STMT_VarDecl {var; init} -> p_dict "STMT_VarDecl" + [ "var", p_var_declaration var + ; "init", p_opt p_expression init + ] + + | STMT_If {loc; cond; then_branch; else_branch} -> p_dict "STMT_If" + [ "loc", p_location loc + ; "cond", p_expression cond + ; "then_branch", p_statement then_branch + ; "else_branch", p_opt p_statement else_branch + ] + + | STMT_While {loc; cond; body} -> p_dict "STMT_While" + [ "loc", p_location loc + ; "cond", p_expression cond + ; "body", p_statement body + ] + + | STMT_Block block -> P_Sequence + [ P_String "STMT_Block " + ; p_statement_block block + ] + + | STMT_MultiVarDecl {loc; vars; init} -> p_dict "STMT_MultiVarDecl" + [ "loc", p_location loc + ; "vars", P_List (List.map (p_opt p_var_declaration) vars) + ; "init", p_call init + ] + + | STMT_Return {loc; values} -> p_dict "STMT_Return" + [ "loc", p_location loc + ; "values", P_List (List.map p_expression values) + ] + +and p_statement_block = function + | STMTBlock {loc; body} -> p_dict "STMTBlock" + [ "loc", p_location loc + ; "body", P_List (List.map p_statement body) + ] + + + +let p_global_declaration = function + | GDECL_Function {loc;id;formal_parameters; return_types; body} -> + p_dict "GDECL_Function" + [ "loc", p_location loc + ; "id", p_identifier id + ; "formal_parameters", P_List (List.map p_var_declaration formal_parameters) + ; "return_types", P_List (List.map p_type_expression return_types) + ; "body", p_opt p_statement_block body + ] + +let p_module_definition = function + | ModuleDefinition {global_declarations} -> P_Sequence + [ P_String "ModuleDefinition " + ; P_List (List.map p_global_declaration global_declarations) + ] + +let show_module_definition mdef = + let p = p_module_definition mdef in + render_r @@ render_p p diff --git a/source/xi_lib/dune b/source/xi_lib/dune new file mode 100644 index 0000000..d4fbe33 --- /dev/null +++ b/source/xi_lib/dune @@ -0,0 +1,9 @@ +(library + (name xi_lib) + (public_name xi_lib) + (libraries ocamlgraph ) + (modes byte) + ; Flaga -linkall potrzebna aby program `xi` był skonsolidowany ze wszystkimi + ; plikami znajdującymi się w xi_lib.cma, to jest w tej bibliotece. + (library_flags (-linkall)) +) \ No newline at end of file diff --git a/source/xi_lib/hardcoded.ml b/source/xi_lib/hardcoded.ml new file mode 100644 index 0000000..314fa1f --- /dev/null +++ b/source/xi_lib/hardcoded.ml @@ -0,0 +1,122 @@ +open Ir + +let word_size = Int32.of_int 4 +let i32_0 = Int32.of_int 0 +let i32_1 = Int32.of_int 1 +let expr_0 = E_Int i32_0 + +let preamble = String.concat "\n" + [ ".data" + ; "endline: .asciiz \"\\n\"" + ; "endmessage: .asciiz \"Exit code: \"" + ; "" + ; ".text" + ; ".set noat" + ; "" + ; "main:" + ; " add $sp, $sp, -4" + ; " sw $ra, 4($sp)" + ; " jal _I_main__i" + ; " move $a1, $v0" + + ; " la $a0, endmessage" + ; " li $v0, 4" + ; " syscall" + + ; " li $v0, 1" + ; " move $a0, $a1" + ; " syscall" + + ; " la $a0, endline" + ; " li $v0, 4" + ; " syscall" + + ; " lw $ra, 4($sp)" + ; " add $sp, $sp, 4" + ; " jr $ra" + ; "" + ; "_xi_length:" + ; " lw $v0, -4($a0)" + ; " jr $ra" + ; "" + ; "_xi_concat:" + ; " # t0 = lhs" + ; " # t1 = rhs" + ; " move $t0, $a0" + ; " move $t1, $a1" + ; " # t2 = len(lhs)" + ; " # t3 = len(rhs)" + ; " lw $t2, -4($t0)" + ; " lw $t3, -4($t1)" + ; " # t4 = len(lhs) + len(rhs)" + ; " addu $t4, $t2, $t3" + ; " # v0 = malloc(4*t4+4) " + ; " li $t5, 4" + ; " mul $a0, $t4, $t5" + ; " addiu $a0, $a0, 4" + ; " li $v0, 9" + ; " syscall" + ; " addiu $v0, $v0, 4" + ; " sw $t4, -4($v0)" + ; " move $v1, $v0" + ; " XL0:" + ; " beq $zero, $t2, XL1" + ; " lw $t4, 0($t0)" + ; " sw $t4, 0($v1)" + ; " addiu $t2, $t2, -1" + ; " addiu $t0, $t0, 4" + ; " addiu $v1, $v1, 4" + ; " j XL0" + ; " XL1:" + ; " beq $zero, $t3, XL2" + ; " lw $t4, 0($t1)" + ; " sw $t4, 0($v1)" + ; " addiu $t3, $t3, -1" + ; " addiu $t1, $t1, 4" + ; " addiu $v1, $v1, 4" + ; " j XL1" + ; " XL2:" + ; " jr $ra" + ; "" + ; "_xi_alloc:" + ; " li $v0, 9" + ; " syscall" + ; " jr $ra" + ; "" + ; "_I_printString_ai_:" + ; " # t0 = len a0" + ; " move $t1, $a0" + ; " lw $t0, -4($t1)" + ; " mul $a0, $t0, 4" + ; " addiu $a0, $a0, 2" + ; " li $v0, 9" + ; " syscall" + ; " move $a0, $v0" + ; " move $v1, $v0" + ; " XL10:" + ; " beq $zero, $t0, XL11" + ; " lw $t2, 0($t1)" + ; " sb $t2, 0($v1)" + ; " addiu $t0, $t0, -1" + ; " addu $t1, $t1, 4" + ; " addu $v1, $v1, 1" + ; " j XL10" + ; " XL11:" + ; " li $t0, 10" + ; " sb $t0, 0($v1)" + ; " sb $zero, 1($v1)" + ; " li $v0, 4" + ; " syscall" + ; " jr $ra" + ; "" + ; "" + ; "_I_printInt_i_:" + ; " li $v0, 1" + ; " syscall" + ; " li $v0, 4" + ; " la $a0, endline" + ; " syscall" + ; " jr $ra" + ; "" + ; "" + ] \ No newline at end of file diff --git a/source/xi_lib/hashset.ml b/source/xi_lib/hashset.ml new file mode 100644 index 0000000..455ba81 --- /dev/null +++ b/source/xi_lib/hashset.ml @@ -0,0 +1,30 @@ + +type 'a t = ('a, unit) Hashtbl.t + +let create () : 'a t = Hashtbl.create 101 + +let clear = Hashtbl.clear + +let add t x = Hashtbl.replace t x () + +let mem = Hashtbl.mem + +let to_seq t = Hashtbl.to_seq_keys t + +let length t = Hashtbl.length t + +let remove t v = Hashtbl.remove t v + +let iter f t = + let g k _ = f k in + Hashtbl.iter g t + + +let fold f t acc = + let g k () = f k in + Hashtbl.fold g t acc + +let of_seq seq : 'a t = + let result = create () in + Seq.iter (add result) seq; + result \ No newline at end of file diff --git a/source/xi_lib/iface.ml b/source/xi_lib/iface.ml new file mode 100644 index 0000000..b67a787 --- /dev/null +++ b/source/xi_lib/iface.ml @@ -0,0 +1,199 @@ + +type node2type = (Ast.node_tag, Types.normal_type) Hashtbl.t + +type schedule = (Ir.procedure, Ir.label list) Hashtbl.t + +type register_mapping = (Ir.reg, Ir.reg) Hashtbl.t + + +module type LEXER = sig + + type token + + val token: Lexing.lexbuf -> token + +end + +module type PARSER = sig + + type token + + exception Error + + val file: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Ast.module_definition + +end + +module type LEXER_AND_PARSER = sig + + type token + + module Lexer: LEXER with type token = token + + module Parser: PARSER with type token = token + +end + +module type TYPECHECKER = sig + + val check_module: Ast.module_definition -> (node2type, Typechecker_errors.type_checking_error list) result + +end + +module type TRANSLATOR = sig + + val translate_module: Ast.module_definition -> node2type -> Ir.program + +end + +module type HI_LOWER = sig + + val lower: Ir.procedure -> unit + +end + +module type MIPS_LOWER = sig + + val lower: Ir.procedure -> unit + +end + +module type CALLCONV = sig + + val callconv: Ir.procedure -> unit + +end + +module type REGISTER_ALLOCATOR = sig + + val regalloc: Ir.procedure -> register_mapping + +end + +module type CODEGEN = sig + + val codegen: schedule -> Ir.program -> Mips32.program + +end + +module type LIVE_VARIABLES_ANALYSIS = sig + + val analyse: Ir.ControlFlowGraph.t -> Analysis_domain.LiveVariables.table +end + +module type REACHABILITY_ANALYSIS = sig + + val analyse: Ir.ControlFlowGraph.t -> Analysis_domain.ReachabilityAnalysis.table + +end + +module type CONSTANT_FOLDING_ANALYSIS = sig + + val analyse: Ir.procedure -> Analysis_domain.ConstantFolding.table + +end + +module type JUMP_THREADING = sig + + val jump_threading: Ir.procedure -> unit + +end + +module type CONSTANT_FOLDING = sig + + val fold_constants: Ir.procedure -> unit + +end + +module type DEAD_CODE_ELIMINATION = sig + + val eliminate_dead_code: Ir.procedure -> unit + +end + +module type DOMINATORS_ANALYSIS = sig + + val analyse: Ir.ControlFlowGraph.t -> Analysis_domain.DominatorsAnalysis.table + +end + +module type NATURAL_LOOPS_ANALYSIS = sig + + val analyse: Ir.ControlFlowGraph.t -> Analysis_domain.DominatorsAnalysis.table -> Analysis_domain.NaturalLoops.table + +end + +module type SCHEDULER = sig + + val schedule: Ir.program -> schedule + +end + +module type SPILL_COSTS_ANALYSIS = sig + + val analyse: Ir.ControlFlowGraph.t -> Analysis_domain.NaturalLoops.table -> (Ir.reg, int) Hashtbl.t + +end + +module type INTERFERENCE_GRAPH_ANALYSIS = sig + + val analyse: Ir.ControlFlowGraph.t -> Analysis_domain.LiveVariables.table -> Ir.RegGraph.t + +end + +module type SPILLING = sig + + val spill: Ir.procedure -> Ir.reg list -> unit + +end + +module type COMPILER_TOOLBOX = sig + + module LiveVariablesAnalysis : LIVE_VARIABLES_ANALYSIS + + module DominatorsAnalysis : DOMINATORS_ANALYSIS + + module NaturalLoopsAnalysis : NATURAL_LOOPS_ANALYSIS + + module SpillCostsAnalysis : SPILL_COSTS_ANALYSIS + + module Scheduler: SCHEDULER + + module RegistersDescription : Ir_arch.REGISTERS_DESCRIPTION + + module ConstantFoldingAnalysis : CONSTANT_FOLDING_ANALYSIS + + module InterferenceGraphAnalysis : INTERFERENCE_GRAPH_ANALYSIS + + module Spilling : SPILLING + + module ReachabilityAnalysis : REACHABILITY_ANALYSIS +end + + +module type COMPILER_STEPS = sig + + module Toolbox: COMPILER_TOOLBOX + + module LexerAndParser: LEXER_AND_PARSER + + module Typechecker: TYPECHECKER + + module Translator: TRANSLATOR + + module JumpThreading: JUMP_THREADING + + module ConstantFolding: CONSTANT_FOLDING + + module HiLower: HI_LOWER + + module CallConv: CALLCONV + + module MipsLower: MIPS_LOWER + + module RegisterAllocator: REGISTER_ALLOCATOR + + module Codegen: CODEGEN + + module DeadCodeElimination: DEAD_CODE_ELIMINATION +end diff --git a/source/xi_lib/ir.ml b/source/xi_lib/ir.ml new file mode 100644 index 0000000..b611916 --- /dev/null +++ b/source/xi_lib/ir.ml @@ -0,0 +1,288 @@ +type reg + = REG_Tmp of int + | REG_Hard of int + | 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 + | _ -> false + +let is_tmp_reg = function + | REG_Tmp _ -> true + | _ -> false + +module RegSet = Set.Make(struct + type t = reg + + let compare = compare + end) + +module RegMap = Map.Make(struct + type t = reg + + let compare = compare + end) + + +module RegGraph = Graph.Imperative.Graph.Concrete(struct +(* module RegGraph = Mygraph.MakeUndirected(struct *) + type t = reg + + let hash = Hashtbl.hash + + let equal a b = compare a b = 0 + + let compare a b = compare a b + end) + +type expr + = E_Reg of reg + | E_Int of Int32.t + + +let reglist_of_expr = function + | E_Reg r -> [r] + | E_Int _ -> [] + +type label + = Label of int + +module LabelSet = Set.Make(struct + type t = label + let compare = compare + end) + +type procid + = Procid of string + + +type cond + = COND_Eq + | COND_Ne + | COND_Lt + | COND_Gt + | 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 + = I_Add of reg * expr * expr + | I_Sub of reg * expr * expr + | I_Div of reg * expr * expr + | I_Rem of reg * expr * expr + | I_Mul of reg * expr * expr + | I_And of reg * expr * expr + | I_Or of reg * expr * expr + | I_Xor of reg * expr * expr + | I_LoadArray of reg * expr * expr + | I_StoreArray of expr * expr * expr + | I_LoadMem of reg * expr * expr + | I_StoreMem of expr * expr * expr + | I_Concat of reg * expr * expr + | I_Neg of reg * expr + | I_Not of reg * expr + | I_Move of reg * expr + | I_Length of reg * expr + | I_NewArray of reg * expr + | I_Call of reg list * procid * expr list * reg list + | I_Set of reg * cond * expr * expr + | I_LoadVar of reg * int + | I_StoreVar of int * expr + | I_LoadStack of reg * int + | I_StoreStack of int * expr + | I_StackAlloc of Int32.t + | I_StackFree of Int32.t + | I_Use of reg list + | I_Def of reg list + + +type terminator = + | T_Return of expr list + | T_Branch of cond * expr * expr * label * label + | T_Jump of label + +let labels_of_terminator = function + | T_Branch (_, _, _, lt, lf) -> [lt; lf] + | T_Jump l -> [l] + | _ -> [] + +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) + +module ControlFlowGraph = struct + + type graph = LabelGraph.t + + type t = Cfg of + { graph: graph + ; blockmap: (label, block) Hashtbl.t + ; terminatormap: (label, terminator) Hashtbl.t + ; entry: label + ; exit: label + } + + let graph (Cfg {graph; _}) = graph + + let _allocate_block graph = + let i = LabelGraph.nb_vertex graph in + let l = Label i in + LabelGraph.add_vertex graph l; + l + + let remove (Cfg {graph; terminatormap; blockmap; _}) v = + LabelGraph.remove_vertex graph v; + Hashtbl.remove terminatormap v; + Hashtbl.remove blockmap v + + let allocate_block (Cfg {graph; blockmap; terminatormap; _}) = + let i = LabelGraph.nb_vertex graph in + let l = Label i in + LabelGraph.add_vertex graph l; + Hashtbl.replace blockmap l []; + Hashtbl.replace terminatormap l (T_Return []); + l + + let create () = + let graph = LabelGraph.create () in + let blockmap = Hashtbl.create 513 in + let terminatormap = Hashtbl.create 513 in + let entry = _allocate_block graph in + let exit = _allocate_block graph in + let _ = LabelGraph.add_vertex graph entry in + let _ = LabelGraph.add_vertex graph exit in + Cfg {graph; blockmap; terminatormap; entry; exit} + + let successors (Cfg {graph; _}) v = + LabelGraph.succ graph v + + let predecessors (Cfg {graph; _}) v = + LabelGraph.pred graph v + + let entry_label (Cfg {entry; _}) = entry + + let exit_label (Cfg {exit; _}) = exit + + let blockmap (Cfg {blockmap;_}) = blockmap + + let blocklist cfg = + let blockmap = blockmap cfg in + let f xs (k,v) = (k,v) :: xs in + let blocks = Seq.fold_left f [] (Hashtbl.to_seq blockmap) in + let blocks = List.sort compare blocks in + blocks + + let terminator (Cfg {terminatormap; entry; exit; _}) v = + assert (entry <> v); + assert (exit <> v); + Hashtbl.find terminatormap v + + let blocklist2 cfg = + let blockmap = blockmap cfg in + let f xs (k,v) = (k,v,terminator cfg k) :: xs in + let blocks = Seq.fold_left f [] (Hashtbl.to_seq blockmap) in + let blocks = List.sort compare blocks in + blocks + + let blocklabels cfg = + let blockmap = blockmap cfg in + let f xs k = k :: xs in + let blocks = Seq.fold_left f [] (Hashtbl.to_seq_keys blockmap) in + let blocks = List.sort compare blocks in + blocks + + + let block (Cfg {blockmap; entry; exit; _}) v = + assert (entry <> v); + assert (exit <> v); + Hashtbl.find blockmap v + + let block_safe (Cfg {blockmap; entry; exit; _}) v = + assert (entry <> v); + assert (exit <> v); + Hashtbl.find_opt blockmap v + + + let terminator_safe (Cfg {terminatormap; entry; exit; _}) v = + assert (entry <> v); + assert (exit <> v); + Hashtbl.find_opt terminatormap v + + let set_block (Cfg {blockmap; entry; exit; _}) v body = + assert (entry <> v); + assert (exit <> v); + Hashtbl.replace blockmap v body + + let set_block2 (Cfg {blockmap; terminatormap; entry; exit; _}) v body terminator = + assert (entry <> v); + assert (exit <> v); + Hashtbl.replace blockmap v body; + Hashtbl.replace terminatormap v terminator + + let set_terminator (Cfg {terminatormap; entry; exit; _}) v body = + assert (entry <> v); + assert (exit <> v); + Hashtbl.replace terminatormap v body + + let connect (Cfg {graph; exit; entry; _}) a b = + assert (entry <> b); + assert (exit <> a); + LabelGraph.add_edge graph a b + + let labels (Cfg {graph; _}) = + LabelGraph.fold_vertex (fun x xs -> x::xs) graph [] + +end + +type procedure = Procedure of + { procid: procid + ; cfg: ControlFlowGraph.t + ; mutable frame_size: int + ; formal_parameters: int + ; allocate_register: unit -> reg + } + +let cfg_of_procedure (Procedure {cfg; _}) = cfg + +let formal_parameters_of_procedure (Procedure {formal_parameters; _}) = formal_parameters + +let allocate_register_of_procedure (Procedure {allocate_register; _}) = allocate_register + +let allocate_frame_slot (Procedure procid) = + let slot = procid.frame_size in + procid.frame_size <- procid.frame_size + 1; + slot + + +let procid_of_procedure (Procedure {procid; _}) = procid + +let frame_size_of_procedure (Procedure {frame_size; _}) = frame_size + + +type program = Program of + { procedures: procedure list + ; externals: procid list + } + +let procedures_of_program (Program{procedures; _}) = procedures + +let externals_of_program (Program{externals; _}) = externals diff --git a/source/xi_lib/ir_arch.ml b/source/xi_lib/ir_arch.ml new file mode 100644 index 0000000..e7ffc60 --- /dev/null +++ b/source/xi_lib/ir_arch.ml @@ -0,0 +1,107 @@ +open Ir + +let reg_fp = REG_Spec 30 + +let reg_sp = REG_Spec 29 + +let reg_ra = REG_Spec 31 + +let reg_zero = REG_Spec 0 + +let expr_reg_zero = E_Reg reg_zero + +let reg_v0 = REG_Hard 2 + +let reg_v1 = REG_Hard 3 + +module type REGISTERS_DESCRIPTION = sig + + val callee_saves_registers : reg list + + val caller_saves_registers : reg list + + val available_registers : reg list + + val arguments_registers : reg list + +end + + +module NormalRegistersDescription : REGISTERS_DESCRIPTION = struct + + let callee_saves_registers = + [ REG_Hard 16 + ; REG_Hard 17 + ; REG_Hard 18 + ; REG_Hard 19 + ; REG_Hard 20 + ; REG_Hard 21 + ; REG_Hard 22 + ; REG_Hard 23 + ] + + let caller_saves_registers = + [ REG_Hard 1 + ; REG_Hard 2 + ; REG_Hard 3 + ; REG_Hard 4 + ; REG_Hard 5 + ; REG_Hard 6 + ; REG_Hard 7 + ; REG_Hard 8 + ; REG_Hard 9 + ; REG_Hard 10 + ; REG_Hard 11 + ; REG_Hard 12 + ; REG_Hard 13 + ; REG_Hard 14 + ; REG_Hard 15 + ; REG_Hard 24 + ; REG_Hard 25 + ] + + let available_registers = List.flatten + [ caller_saves_registers + ; callee_saves_registers + ] + + let arguments_registers = + [ REG_Hard 4 + ; REG_Hard 5 + ; REG_Hard 6 + ; REG_Hard 7 + ] + +end + +module SimpleCallerRegistersDescription : REGISTERS_DESCRIPTION = struct + + let callee_saves_registers = + [ + ] + + let caller_saves_registers = + [ REG_Hard 2 + ; REG_Hard 3 + ; REG_Hard 4 + ; REG_Hard 5 + ; REG_Hard 6 + ; REG_Hard 7 + ] + + let available_registers = List.flatten + [ callee_saves_registers + ; caller_saves_registers + ] + + let arguments_registers = + [ REG_Hard 4 + ; REG_Hard 5 + ] + +end + +let descriptions = + [ "normal", (module NormalRegistersDescription : REGISTERS_DESCRIPTION ) + ; "simple_caller", (module SimpleCallerRegistersDescription : REGISTERS_DESCRIPTION ) + ] \ No newline at end of file diff --git a/source/xi_lib/ir_utils.ml b/source/xi_lib/ir_utils.ml new file mode 100644 index 0000000..48b59a1 --- /dev/null +++ b/source/xi_lib/ir_utils.ml @@ -0,0 +1,668 @@ +open Ir + +let remap_register_reg sb r = + try + Hashtbl.find sb r + with Not_found -> + r + +let remap_register_expr sb = function + | E_Reg r -> E_Reg (remap_register_reg sb r) + | e -> e + +let remap_register_instr sb = function + | I_Add (r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Add (r0, r1, r2) + + | I_Sub (r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Sub (r0, r1, r2) + + | I_Div (r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Div (r0, r1, r2) + + | I_Rem (r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Rem (r0, r1, r2) + + | I_Mul(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Mul (r0, r1, r2) + + | I_And(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_And(r0, r1, r2) + + | I_Or(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Or(r0, r1, r2) + + | I_Xor(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Xor(r0, r1, r2) + + | I_LoadArray(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_LoadArray(r0, r1, r2) + + | I_StoreArray(r0, r1, r2) -> + let r0 = remap_register_expr sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_StoreArray(r0, r1, r2) + + | I_LoadMem(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_LoadMem(r0, r1, r2) + + | I_StoreMem(r0, r1, r2) -> + let r0 = remap_register_expr sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_StoreMem(r0, r1, r2) + + | I_Concat(r0, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Concat(r0, r1, r2) + + | I_Neg(r0, r1) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + I_Neg(r0, r1) + + | I_Not(r0, r1) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + I_Not(r0, r1) + + | I_Move(r0, r1) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + I_Move(r0, r1) + + | I_Length(r0, r1) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + I_Length(r0, r1) + + | I_NewArray(r0, r1) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + I_NewArray(r0, r1) + + | I_Set(r0, cond, r1, r2) -> + let r0 = remap_register_reg sb r0 in + let r1 = remap_register_expr sb r1 in + let r2 = remap_register_expr sb r2 in + I_Set(r0, cond, r1, r2) + + | I_LoadVar(r0, i) -> + let r0 = remap_register_reg sb r0 in + I_LoadVar(r0, i) + + | I_StoreVar(i, r0) -> + let r0 = remap_register_expr sb r0 in + I_StoreVar(i, r0) + + | I_LoadStack(r0, i) -> + let r0 = remap_register_reg sb r0 in + I_LoadStack(r0, i) + + | I_StoreStack(i, r0) -> + let r0 = remap_register_expr sb r0 in + I_StoreStack(i, r0) + + | I_StackAlloc i -> + I_StackAlloc i + + | I_StackFree i -> + I_StackFree i + + | I_Use rs -> + I_Use (List.map (remap_register_reg sb) rs) + + | I_Def rs -> + I_Def (List.map (remap_register_reg sb) rs) + + | I_Call (rs, procid, args, kills) -> + let rs = List.map (remap_register_reg sb) rs in + let args = List.map (remap_register_expr sb) args in + let kills = List.map (remap_register_reg sb) kills in + I_Call (rs, procid, args, kills) + +let subst_expr rmap = function + | (E_Reg r) as e -> + begin match RegMap.find_opt r rmap with + | None -> e + | Some e -> e + end + | e -> e + +let subst_expr_instr sb = function + | I_Add (r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Add (r0, r1, r2) + + | I_Sub (r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Sub (r0, r1, r2) + + | I_Div (r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Div (r0, r1, r2) + + | I_Rem (r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Rem (r0, r1, r2) + + | I_Mul(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Mul (r0, r1, r2) + + | I_And(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_And(r0, r1, r2) + + | I_Or(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Or(r0, r1, r2) + + | I_Xor(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Xor(r0, r1, r2) + + | I_LoadArray(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_LoadArray(r0, r1, r2) + + | I_StoreArray(r0, r1, r2) -> + let r0 = subst_expr sb r0 in + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_StoreArray(r0, r1, r2) + + | I_LoadMem(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_LoadMem(r0, r1, r2) + + | I_StoreMem(r0, r1, r2) -> + let r0 = subst_expr sb r0 in + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_StoreMem(r0, r1, r2) + + | I_Concat(r0, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Concat(r0, r1, r2) + + | I_Neg(r0, r1) -> + let r1 = subst_expr sb r1 in + I_Neg(r0, r1) + + | I_Not(r0, r1) -> + let r1 = subst_expr sb r1 in + I_Not(r0, r1) + + | I_Move(r0, r1) -> + let r1 = subst_expr sb r1 in + I_Move(r0, r1) + + | I_Length(r0, r1) -> + let r1 = subst_expr sb r1 in + I_Length(r0, r1) + + | I_NewArray(r0, r1) -> + let r1 = subst_expr sb r1 in + I_NewArray(r0, r1) + + | I_Set(r0, cond, r1, r2) -> + let r1 = subst_expr sb r1 in + let r2 = subst_expr sb r2 in + I_Set(r0, cond, r1, r2) + + | I_LoadVar(r0, i) -> + I_LoadVar(r0, i) + + | I_StoreVar(i, r0) -> + let r0 = subst_expr sb r0 in + I_StoreVar(i, r0) + + | I_LoadStack(r0, i) -> + I_LoadStack(r0, i) + + | I_StoreStack(i, r0) -> + let r0 = subst_expr sb r0 in + I_StoreStack(i, r0) + + | I_StackAlloc i -> + I_StackAlloc i + + | I_StackFree i -> + I_StackFree i + + | I_Use rs -> + I_Use rs + + | I_Def rs -> + I_Def rs + + | I_Call (rs, procid, args, kills) -> + let args = List.map (subst_expr sb) args in + I_Call (rs, procid, args, kills) + +let remap_label_label sb l = + try + Hashtbl.find sb l + with Not_found -> + l + +let remap_label_terminator sb = function + | T_Jump l -> + T_Jump (remap_label_label sb l) + + | T_Branch (cond, r0, r1, lt, lf) -> + T_Branch (cond, r0, r1, remap_label_label sb lt, remap_label_label sb lf) + + | t -> + t + +let remap_register_terminator sb = function + | T_Return xs -> + let xs = List.map (remap_register_expr sb) xs in + T_Return xs + + | T_Branch (cond, r0, r1, l1, l2) -> + let r0 = remap_register_expr sb r0 in + let r1 = remap_register_expr sb r1 in + T_Branch (cond, r0, r1, l1, l2) + + | T_Jump l -> + T_Jump l + +let subst_expr_terminator sb = function + | T_Return xs -> + let xs = List.map (subst_expr sb) xs in + T_Return xs + + | T_Branch (cond, r0, r1, l1, l2) -> + let r0 = subst_expr sb r0 in + let r1 = subst_expr sb r1 in + T_Branch (cond, r0, r1, l1, l2) + + | T_Jump l -> + T_Jump l + +let defined_registers_instr = function + | I_Add (r0, _, _) + | I_Sub (r0, _, _) + | I_Div (r0, _, _) + | I_Mul (r0, _, _) + | I_And (r0, _, _) + | I_Or (r0, _, _) + | I_Xor (r0, _, _) + | I_LoadArray (r0, _, _) + | I_LoadMem (r0, _, _) + | I_Concat (r0, _, _) + | I_Not (r0, _) + | I_Move (r0, _) + | I_Length (r0, _) + | I_NewArray (r0, _) + | I_Neg (r0, _) + | I_Set (r0, _, _, _) + | I_Rem (r0, _, _) + | I_LoadStack (r0, _) + | I_LoadVar (r0, _) -> + [r0] + + + | I_Call (outs, _, _, kills) -> + outs @ kills + + | I_Use _ + | I_StoreVar _ + | I_StoreStack _ + | I_StackAlloc _ + | I_StackFree _ + | I_StoreMem _ + | I_StoreArray _ -> + [] + + | I_Def rs -> + rs + +let defined_registers_terminator _ = [] + +let used_registers_instr = function + | I_Add (_, r0, r1) + | I_Sub (_, r0, r1) + | I_Div (_, r0, r1) + | I_Mul (_, r0, r1) + | I_And (_, r0, r1) + | I_Or (_, r0, r1) + | I_Xor (_, r0, r1) + | I_LoadArray (_, r0, r1) + | I_LoadMem (_, r0, r1) + | I_Concat (_, r0, r1) + | I_Set (_, _, r0, r1) + | I_Rem (_, r0, r1) -> + List.flatten @@ List.map reglist_of_expr [r0;r1] + + | I_Not (_, r0) + | I_Move (_, r0) + | I_Length (_, r0) + | I_NewArray (_, r0) + | I_StoreVar (_, r0) + | I_StoreStack (_, r0) + | I_Neg (_, r0) -> + reglist_of_expr r0 + + | I_Call (_, _, args, _) -> + List.flatten @@ List.map reglist_of_expr args + + | I_Def _ + | I_StackAlloc _ + | I_StackFree _ + | I_LoadStack _ + | I_LoadVar _ -> + [] + + | I_StoreArray (r0, r1, r2) + | I_StoreMem (r0, r1, r2) -> + List.flatten @@ List.map reglist_of_expr [r0; r1; r2] + + | I_Use rs -> + rs + +let used_registers_terminator = function + | T_Branch (_, r0, r1, _, _) -> + List.flatten @@ List.map reglist_of_expr [r0;r1] + + + | T_Return args -> + List.flatten @@ List.map reglist_of_expr args + + | T_Jump _ -> + [] + +let remap_registers_proc sb proc = + let cfg = (cfg_of_procedure proc) in + let remap_block (l, body, terminator) = + let body = List.map (remap_register_instr sb) body in + let terminator = remap_register_terminator sb terminator in + (l, body, terminator) + in + let update_blocks (l, body, terminator) = + ControlFlowGraph.set_block2 cfg l body terminator + in + + let blocks = ControlFlowGraph.blocklist2 cfg in + let blocks = List.map remap_block blocks in + List.iter update_blocks blocks + +let string_of_expr = function + | E_Reg r -> string_of_reg r + | E_Int i -> Int32.to_string i + +let string_of_label = function + | Label i -> Format.sprintf "L%u" i + +let string_of_procid = function + | Procid l -> Format.sprintf "%s" l + +let string_of_reglist xs = + Format.sprintf "[%s]" (String.concat ", " @@ List.map string_of_reg xs) + +let string_of_labellist xs = + Format.sprintf "[%s]" (String.concat ", " @@ List.map string_of_label xs) + +let string_of_exprlist xs = + Format.sprintf "[%s]" (String.concat ", " @@ List.map string_of_expr xs) + +let string_of_expr_regmap k = + let f (k, v) = Format.sprintf "%s=%s" (string_of_reg k) (string_of_expr v) in + String.concat "; " @@ List.of_seq @@ Seq.map f @@ RegMap.to_seq k +let string_of_instr = function + | I_Add (r0, e0, e1) -> + Format.sprintf "add %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Sub (r0, e0, e1) -> + Format.sprintf "sub %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Div (r0, e0, e1) -> + Format.sprintf "div %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Rem (r0, e0, e1) -> + Format.sprintf "rem %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Mul (r0, e0, e1) -> + Format.sprintf "mul %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_And (r0, e0, e1) -> + Format.sprintf "and %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Or (r0, e0, e1) -> + Format.sprintf "or %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Xor (r0, e0, e1) -> + Format.sprintf "xor %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_LoadArray (r0, e0, e1) -> + Format.sprintf "loadarray %s, %s, %s // %s = %s[%s]" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_LoadMem (r0, e0, e1) -> + Format.sprintf "loadmem %s, %s, %s // %s = mem[%s + %s]" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_StoreArray (r0, e0, e1) -> + Format.sprintf "storearray %s, %s, %s // %s[%s] = %s" + (string_of_expr r0) + (string_of_expr e0) + (string_of_expr e1) + (string_of_expr r0) + (string_of_expr e0) + (string_of_expr e1) + | I_StoreMem (r0, e0, e1) -> + Format.sprintf "storemem %s, %s, %s // mem[%s + %s] = %s" + (string_of_expr r0) + (string_of_expr e0) + (string_of_expr e1) + (string_of_expr r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Concat (r0, e0, e1) -> + Format.sprintf "concat %s, %s, %s" + (string_of_reg r0) + (string_of_expr e0) + (string_of_expr e1) + | I_Neg (r0, e0) -> + Format.sprintf "neg %s, %s" + (string_of_reg r0) + (string_of_expr e0) + | I_Not (r0, e0) -> + Format.sprintf "not %s, %s" + (string_of_reg r0) + (string_of_expr e0) + | I_Length (r0, e0) -> + Format.sprintf "length %s, %s" + (string_of_reg r0) + (string_of_expr e0) + | I_Move (r0, e0) -> + Format.sprintf "move %s, %s" + (string_of_reg r0) + (string_of_expr e0) + | I_NewArray (r0, e0) -> + Format.sprintf "newarray %s, %s" + (string_of_reg r0) + (string_of_expr e0) + | I_Call (rs, p, xs, kill) -> + Format.sprintf "call %s, %s, %s, kill %s" + (string_of_reglist rs) + (string_of_procid p) + (string_of_exprlist xs) + (string_of_reglist kill) + | I_Set (rr, cond, r0, r1) -> + Format.sprintf "set %s, %s, %s, %s" + (string_of_reg rr) + (string_of_cond cond) + (string_of_expr r0) + (string_of_expr r1) + | I_StoreVar (i0, e0) -> + Format.sprintf "storevar %s, %s" + (string_of_int i0) + (string_of_expr e0) + | I_LoadVar (r0, i0) -> + Format.sprintf "loadvar %s, %s" + (string_of_reg r0) + (string_of_int i0) + | I_StoreStack (i0, e0) -> + Format.sprintf "storestack %s, %s" + (string_of_int i0) + (string_of_expr e0) + | I_LoadStack (r0, i0) -> + Format.sprintf "loadstack %s, %s" + (string_of_reg r0) + (string_of_int i0) + | I_StackAlloc (i0) -> + Format.sprintf "stackalloc %s" + (Int32.to_string i0) + | I_StackFree (i0) -> + Format.sprintf "stackfree %s" + (Int32.to_string i0) + | I_Use rs -> + Format.sprintf "use %s" (string_of_reglist rs) + | I_Def rs -> + Format.sprintf "def %s" (string_of_reglist rs) + +let string_of_terminator = function + | T_Branch (cond, r0, r1, l1, l2) -> + Format.sprintf "branch %s, %s, %s, %s, %s" + (string_of_cond cond) + (string_of_expr r0) + (string_of_expr r1) + (string_of_label l1) + (string_of_label l2) + | T_Jump (l) -> + Format.sprintf "jump %s" + (string_of_label l) + | T_Return xs -> + Format.sprintf "return %s" + (string_of_exprlist xs) + +let indented_string_of_instr i = " " ^ (string_of_instr i) +let indented_string_of_terminator i = " " ^ (string_of_terminator i) + +let string_of_block_body cfg label body = + String.concat "\n" + [ Format.sprintf "%s:" (string_of_label label) + ; Format.sprintf " cfg successors: %s" + (string_of_labellist @@ ControlFlowGraph.successors cfg label) + ; Format.sprintf " cfg predecessors: %s" + (string_of_labellist @@ ControlFlowGraph.predecessors cfg label) + ; String.concat "\n" (List.map indented_string_of_instr body) + ] + +let string_of_block cfg k v = + let terminator = match ControlFlowGraph.terminator_safe cfg k with + | None -> "<<no terminator>>" + | Some t -> indented_string_of_terminator t + in + String.concat "\n" + [ string_of_block_body cfg k v + ; terminator + ] + +let string_of_blockmap cfg = + let f xs (k, v) = string_of_block cfg k v :: xs in + let items = Seq.fold_left (fun xs x -> x::xs) [] (Hashtbl.to_seq @@ ControlFlowGraph.blockmap cfg) in + let items = List.sort compare items in + String.concat "\n" @@ List.rev @@ List.fold_left f [] items + +let string_of_cfg cfg = + String.concat "\n" + [ Format.sprintf " cfg entry point: %s" (string_of_label @@ ControlFlowGraph.entry_label cfg) + + ; Format.sprintf " cfg entry point successors: %s" + (string_of_labellist @@ ControlFlowGraph.successors cfg @@ ControlFlowGraph.entry_label cfg) + + ; Format.sprintf " cfg exit point: %s" (string_of_label @@ ControlFlowGraph.exit_label cfg) + + ; Format.sprintf " cfg exit point predecessors : %s" + (string_of_labellist @@ ControlFlowGraph.predecessors cfg @@ ControlFlowGraph.exit_label cfg) + + ; string_of_blockmap cfg + ] + +let string_of_procedure (Procedure {procid; cfg; frame_size; formal_parameters; _}) = + String.concat "\n" + [ "////////////////////////////////////// " + ; Format.sprintf "procedure %s" (string_of_procid procid) + ; Format.sprintf " frame size: %u" frame_size + ; Format.sprintf " formal parameters: %u" formal_parameters + ; string_of_cfg cfg + ] + +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 diff --git a/source/xi_lib/logger.ml b/source/xi_lib/logger.ml new file mode 100644 index 0000000..746bbb8 --- /dev/null +++ b/source/xi_lib/logger.ml @@ -0,0 +1,170 @@ +module FS = struct + + let removedir = + let rec rm path item = + let p = (Filename.concat path item) in + if Sys.is_directory p then + let items = Sys.readdir p in + Array.iter (rm p) items; + Unix.rmdir p; + else + Sys.remove p + in + fun item -> + if Sys.file_exists item then + rm "" item + + + let xilog_dir = ref "xilog" + + let init xilog = + xilog_dir := xilog; + removedir xilog; + Unix.mkdir xilog 0o777 +end + + +module State = struct + + let extra_debug = ref false + + let counter = ref 0 + + let phase_name = ref "" + + let proc_name = ref "" + + let log_file_name = ref "" + + let log_file_handle : out_channel option ref = ref None + + let get_lof_file_handle () = + match !log_file_handle with + | Some handle -> + handle + | None -> + assert (!log_file_name <> ""); + let handle = open_out !log_file_name in + log_file_handle := Some handle; + handle + + let close_log_file () = + match !log_file_handle with + | None -> + () + | Some handle -> + close_out handle; + log_file_name := ""; + log_file_handle := None + + let make_entry_name = function + | () when !phase_name <> "" && !proc_name <> "" -> + Format.sprintf "%03u.%s.%s" !counter !phase_name !proc_name + | () when !phase_name <> "" -> + Format.sprintf "%03u.%s" !counter !phase_name + | _ -> + Format.sprintf "%03u.unknown-phase" !counter + + let allocate_file_name title = + let r = Format.sprintf "%s/%s.%s" !FS.xilog_dir (make_entry_name ()) title in + incr counter; + r + + let set_new_phase name = + phase_name := name; + proc_name := ""; + close_log_file (); + log_file_name := allocate_file_name "log" + + + let set_proc_phase procid = + proc_name := Ir_utils.string_of_procid procid; + close_log_file (); + log_file_name := allocate_file_name "log" + + + let close_phase_proc () = + proc_name := ""; + close_log_file (); + log_file_name := allocate_file_name "log" + + let set_extra_debug v = + extra_debug := v +end + + +let extra_debug f = + if !State.extra_debug then + f () + +let set_extra_debug = State.set_extra_debug + +let new_phase name = + State.set_new_phase name + +let new_phase_proc procid = + State.set_proc_phase procid + +let close_phase_proc () = + State.close_phase_proc () + +let make_logf mname fmt = + let cont s = + let h = State.get_lof_file_handle () in + let entry = Format.sprintf "%s: %s\n" mname s in + output_string h entry; + flush h + in + Format.ksprintf cont fmt + +let dump_string title buffer = + let name = State.allocate_file_name title in + make_logf __MODULE__ "Dumping %s" (Filename.basename name); + let h = open_out name in + output_string h buffer; + output_string h "\n"; + close_out h + +let dump_ir_program title ir = + let buffer = Ir_utils.string_of_program ir in + dump_string title buffer + +let dump_ir_proc title irproc = + let buffer = Ir_utils.string_of_procedure irproc in + 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 seq = Hashtbl.to_seq spill_costs in + let seq = Seq.map f seq in + let seq = List.of_seq seq in + let buf = String.concat "\n" @@ List.sort compare seq in + 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 seq = Hashtbl.to_seq spill_costs in + let seq = Seq.map f seq in + let seq = List.of_seq seq in + let buf = String.concat "\n" @@ List.sort compare seq in + dump_string "spill_costs" buf + + +let log_ir_proc mname irproc = + let buffer = Ir_utils.string_of_procedure irproc in + make_logf mname "%s" buffer + +let dump_interference_graph title x = + let buffer = Analysis_visualizer.visualize_interference_graph x in + dump_string (title ^ ".infg.xdot") buffer + +let dump_live_variables title cfg table = + let buffer = Analysis_visualizer.visualize_live_variables cfg table in + dump_string (title ^ ".lva.xdot") buffer + +let dump_constant_folding title cfg table = + let buffer = Analysis_visualizer.visualize_constant_folding cfg table in + dump_string (title ^ ".cfa.xdot") buffer + +let init xilog = + FS.init xilog \ No newline at end of file diff --git a/source/xi_lib/measure.ml b/source/xi_lib/measure.ml new file mode 100644 index 0000000..1aec0b9 --- /dev/null +++ b/source/xi_lib/measure.ml @@ -0,0 +1,8 @@ +let logf fmt = Logger.make_logf __MODULE__ fmt + +let measure name f = + let t_start = Unix.gettimeofday () in + let r = f () in + let t_end = Unix.gettimeofday () in + logf "%s: execution time %f" name (t_end -. t_start); + r \ No newline at end of file diff --git a/source/xi_lib/mips32.ml b/source/xi_lib/mips32.ml new file mode 100644 index 0000000..99735b3 --- /dev/null +++ b/source/xi_lib/mips32.ml @@ -0,0 +1,217 @@ + +type reg = + | Reg of int + +let string_of_reg_raw (Reg i) = Format.sprintf "$%u" i + +let string_of_reg = function + | Reg 0 -> "$zero" + | Reg 1 -> "$at" + | Reg 2 -> "$v0" + | Reg 3 -> "$v1" + | Reg 4 -> "$a0" + | Reg 5 -> "$a1" + | Reg 6 -> "$a2" + | Reg 7 -> "$a3" + | Reg 8 -> "$t0" + | Reg 9 -> "$t1" + | Reg 10 -> "$t2" + | Reg 11 -> "$t3" + | Reg 12 -> "$t4" + | Reg 13 -> "$t5" + | Reg 14 -> "$t6" + | Reg 15 -> "$t7" + | Reg 16 -> "$s0" + | Reg 17 -> "$s1" + | Reg 18 -> "$s2" + | Reg 19 -> "$s3" + | Reg 20 -> "$s4" + | Reg 21 -> "$s5" + | Reg 22-> "$s6" + | Reg 23 -> "$s7" + | Reg 24 -> "$t8" + | Reg 25 -> "$t9" + | Reg 26 -> "$k0" + | Reg 27 -> "$k1" + | Reg 28 -> "$gp" + | Reg 29 -> "$sp" + | Reg 30 -> "$fp" + | Reg 31 -> "$ra" + | r -> string_of_reg_raw r + +let reg_zero = Reg 0 +let reg_sp = Reg 29 +let reg_fp = Reg 30 +let reg_ra = Reg 31 + +let reg_s = function + | i when i < 8 -> + Reg (16 + i) + | i -> failwith @@ Format.sprintf "There is no $sp%u" i + +type label = + | Label of string + +let string_of_label (Label s) = s + +type instr = + | I_Label of label + | I_Add of reg * reg * reg + | I_Addu of reg * reg * reg + | I_Addi of reg * reg * Int32.t + | I_Addiu of reg * reg * Int32.t + | I_Sub of reg * reg * reg + | I_Subu of reg * reg * reg + | I_Div of reg * reg + | I_Mult of reg * reg + | I_Multu of reg * reg + | I_And of reg * reg * reg + | I_Andi of reg * reg * Int32.t + | I_Nor of reg * reg * reg + | I_Or of reg * reg * reg + | I_Ori of reg * reg * Int32.t + | I_Xor of reg * reg * reg + | I_Xori of reg * reg * Int32.t + | I_Sll of reg * reg * reg + | I_Sllv of reg * reg * reg + | I_Sra of reg * reg * reg + | I_Srav of reg * reg * reg + | I_Srl of reg * reg * reg + | I_Rol of reg * reg * reg + | I_Ror of reg * reg * reg + | I_Srlv of reg * reg * reg + | I_Mfhi of reg + | I_Mflo of reg + | I_Lui of reg * Int32.t + | I_Lb of reg * Int32.t * reg + | I_Sb of reg * Int32.t * reg + | I_Lw of reg * Int32.t * reg + | I_Sw of reg * Int32.t * reg + | I_Slt of reg * reg * reg + | I_Slti of reg * reg * Int32.t + | I_Sltu of reg * reg * reg + | I_Beq of reg * reg * label + | I_Bgez of reg * label + | I_Bgezal of reg * label + | I_Bgtz of reg * label + | I_Blez of reg * label + | I_Bltz of reg * label + | I_Bltzal of reg * label + | I_Bne of reg * reg * label + | I_J of label + | I_Jal of label + | I_Jr of reg + | I_Jalr of reg + | I_Nop + +let string_of_instr = function + | I_Label l -> Format.sprintf "%s:" + (string_of_label l) + |I_Add (r0, r1, r2) -> Format.sprintf "add %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Addu (r0, r1, r2) -> Format.sprintf "addu %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Addiu (r0, r1, i) -> Format.sprintf "addiu %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (Int32.to_string i) + |I_Addi (r0, r1, i) -> Format.sprintf "addi %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (Int32.to_string i) + |I_Sub (r0, r1, r2) -> Format.sprintf "sub %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Subu (r0, r1, r2) -> Format.sprintf "subu %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Div (r0, r1) -> Format.sprintf "div %s, %s" + (string_of_reg r0) (string_of_reg r1) + |I_Mult (r0, r1) -> Format.sprintf "mult %s, %s" + (string_of_reg r0) (string_of_reg r1) + |I_Multu (r0, r1) -> Format.sprintf "multu %s, %s" + (string_of_reg r0) (string_of_reg r1) + |I_And (r0, r1, r2) -> Format.sprintf "and %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Andi (r0, r1, i) -> Format.sprintf "andi %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (Int32.to_string i) + |I_Nor (r0, r1, r2) -> Format.sprintf "nor %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Or (r0, r1, r2) -> Format.sprintf "or %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Ori (r0, r1, i) -> Format.sprintf "ori %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (Int32.to_string i) + |I_Xor (r0, r1, r2) -> Format.sprintf "xor %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Xori (r0, r1, i) -> Format.sprintf "xori %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (Int32.to_string i) + |I_Sll (r0, r1, r2) -> Format.sprintf "sll %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Sllv (r0, r1, r2) -> Format.sprintf "sllv %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Srl (r0, r1, r2) -> Format.sprintf "srl %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Srlv (r0, r1, r2) -> Format.sprintf "srlv %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Mfhi (r0) -> Format.sprintf "mfhi %s" + (string_of_reg r0) + |I_Mflo (r0) -> Format.sprintf "mflo %s" + (string_of_reg r0) + |I_Lui (r0, i) -> Format.sprintf "lui %s, %s" + (string_of_reg r0) (Int32.to_string i) + |I_Lb (r0, i0, r1) -> Format.sprintf "lb %s, %s(%s)" + (string_of_reg r0) (Int32.to_string i0) (string_of_reg r1) + |I_Sb (r0, i0, r1) -> Format.sprintf "sb %s, %s(%s)" + (string_of_reg r0) (Int32.to_string i0) (string_of_reg r1) + |I_Lw (r0, i0, r1) -> Format.sprintf "lw %s, %s(%s)" + (string_of_reg r0) (Int32.to_string i0) (string_of_reg r1) + |I_Sw (r0, i0, r1) -> Format.sprintf "sw %s, %s(%s)" + (string_of_reg r0) (Int32.to_string i0) (string_of_reg r1) + |I_Slt (r0, r1, r2) -> Format.sprintf "slt %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Sra (r0, r1, r2) -> Format.sprintf "sra %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Srav (r0, r1, r2) -> Format.sprintf "srav %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Rol (r0, r1, r2) -> Format.sprintf "srav %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Ror (r0, r1, r2) -> Format.sprintf "srav %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Slti (r0, r1, i) -> Format.sprintf "slti %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (Int32.to_string i) + |I_Sltu (r0, r1, r2) -> Format.sprintf "sltu %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_reg r2) + |I_Beq (r0, r1, l) -> Format.sprintf "beq %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_label l) + |I_Bgez (r0, l) -> Format.sprintf "bgez %s, %s" + (string_of_reg r0) (string_of_label l) + |I_Bgezal (r0, l) -> Format.sprintf "bgezal %s, %s" + (string_of_reg r0) (string_of_label l) + |I_Bgtz (r0, l) -> Format.sprintf "bgtz %s, %s" + (string_of_reg r0) (string_of_label l) + |I_Blez (r0, l) -> Format.sprintf "blez %s, %s" + (string_of_reg r0) (string_of_label l) + |I_Bltz (r0, l) -> Format.sprintf "bltz %s, %s" + (string_of_reg r0) (string_of_label l) + |I_Bltzal (r0, l) -> Format.sprintf "bltzal %s, %s" + (string_of_reg r0) (string_of_label l) + |I_Bne (r0, r1, l) -> Format.sprintf "bne %s, %s, %s" + (string_of_reg r0) (string_of_reg r1) (string_of_label l) + |I_J (l) -> Format.sprintf "j %s" + (string_of_label l) + |I_Jal (l) -> Format.sprintf "jal %s" + (string_of_label l) + |I_Jr (r0) -> Format.sprintf "jr %s" + (string_of_reg r0) + |I_Jalr (r0) -> Format.sprintf "jalr %s" + (string_of_reg r0) + | I_Nop -> Format.sprintf "add $zero, $zero, $zero" + +type program = (label * instr list) list + + +let indent x = " " ^ x + +let string_of_program (l, b) = + String.concat "\n" + [ Format.sprintf "%s:" (string_of_label l) + ; String.concat "\n" (List.map indent @@ List.map string_of_instr b) + ] + +let string_of_program xs = + String.concat "\n" + (List.map string_of_program xs) diff --git a/source/xi_lib/mygraph.ml b/source/xi_lib/mygraph.ml new file mode 100644 index 0000000..5836414 --- /dev/null +++ b/source/xi_lib/mygraph.ml @@ -0,0 +1,155 @@ + +(* Just to keep compatibility with Ocamlgraph *) +module type SElem = sig + + type t + + val compare: t -> t -> int + + val hash: t -> int + + val equal: t -> t -> bool + +end + +module MakeBidirectional(V:SElem) = struct + + type t = + { g_successors: (V.t, V.t Hashset.t) Hashtbl.t + ; g_predecessors: (V.t, V.t Hashset.t) Hashtbl.t + ; g_vertices : V.t Hashset.t + } + + let create () = + { g_successors = Hashtbl.create 101 + ; g_predecessors = Hashtbl.create 101 + ; g_vertices = Hashset.create () + } + + let nb_vertex g = + Hashset.length g.g_vertices + + let _assert_mem g v = + assert (Hashset.mem g.g_vertices v) + + let add_vertex g v = + if not @@ Hashset.mem g.g_vertices v then begin + Hashset.add g.g_vertices v; + Hashtbl.replace g.g_successors v @@ Hashset.create (); + Hashtbl.replace g.g_predecessors v @@ Hashset.create () + end + + let _succ g v = + Hashtbl.find g.g_successors v + + let _pred g v = + Hashtbl.find g.g_predecessors v + + let remove_vertex g v = + _assert_mem g v; + Hashset.remove g.g_vertices v; + let remove_pred w = + let pred = _pred g w in + Hashset.remove pred v + in + let succ = _succ g v in + Hashset.iter remove_pred succ + + let add_edge g v w = + add_vertex g v; + add_vertex g w; + let v_succ = _succ g v in + let w_pred = _pred g w in + Hashset.add v_succ w; + Hashset.add w_pred v + + let fold_vertex f g acc = + Hashset.fold f g.g_vertices acc + + let succ g v = + _assert_mem g v; + List.of_seq @@ Hashset.to_seq @@ _succ g v + + let pred g v = + _assert_mem g v; + List.of_seq @@ Hashset.to_seq @@ _pred g v + + let remove_edge g v w = + _assert_mem g v; + _assert_mem g w; + let v_succ = _succ g v in + let w_pred = _pred g w in + Hashset.remove v_succ w; + Hashset.remove w_pred v + +end + +module MakeUndirected(V:SElem) = struct + + type t = + { g_neighbours: (V.t, V.t Hashset.t) Hashtbl.t + } + + let create () = + { g_neighbours = Hashtbl.create 101 + } + + let nb_vertex g = + Hashtbl.length g.g_neighbours + + let _assert_mem g v = + assert (Hashtbl.mem g.g_neighbours v) + + let add_vertex g v = + if not @@ Hashtbl.mem g.g_neighbours v then begin + Hashtbl.replace g.g_neighbours v @@ Hashset.create (); + end + + let _nb g v = + Hashtbl.find g.g_neighbours v + + let remove_vertex g v = + _assert_mem g v; + let remove_pred w = + let pred = _nb g w in + Hashset.remove pred v + in + let succ = _nb g v in + Hashset.iter remove_pred succ; + Hashtbl.remove g.g_neighbours v + + let add_edge g v w = + add_vertex g v; + add_vertex g w; + let v_nb = _nb g v in + let w_nb = _nb g w in + Hashset.add v_nb w; + Hashset.add w_nb v + + let fold_vertex f g acc = + let h k _ = f k in + Hashtbl.fold h g.g_neighbours acc + + let succ g v = + _assert_mem g v; + List.of_seq @@ Hashset.to_seq @@ _nb g v + + let fold_edges f g acc = + let h v nb acc = + let f' w acc = f w v acc in + Hashset.fold f' nb acc + in + Hashtbl.fold h g.g_neighbours acc + + let iter_edges f g = + let h v nb = + let f' w = f w v in + Hashset.iter f' nb + in + Hashtbl.iter h g.g_neighbours + + let out_degree g v = + _assert_mem g v; + Hashset.length @@ _nb g v + +end \ No newline at end of file diff --git a/source/xi_lib/parser_utils.ml b/source/xi_lib/parser_utils.ml new file mode 100644 index 0000000..0600d8b --- /dev/null +++ b/source/xi_lib/parser_utils.ml @@ -0,0 +1,7 @@ +exception InvalidToken of Ast.location * string + +let mkLocation pos = + let line = pos.Lexing.pos_lnum in + let column = pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1 in + let file = pos.Lexing.pos_fname in + Ast.Location {line; column; file} \ No newline at end of file diff --git a/source/xi_lib/plugin.ml b/source/xi_lib/plugin.ml new file mode 100644 index 0000000..33e6e4e --- /dev/null +++ b/source/xi_lib/plugin.ml @@ -0,0 +1,85 @@ +open Iface + + +module type MAKE_NATURAL_LOOPS_ANALYSIS = functor () -> NATURAL_LOOPS_ANALYSIS + +module type MAKE_SPILL_COSTS_ANALYSIS = functor () -> SPILL_COSTS_ANALYSIS + +module type MAKE_LIVE_VARIABLES_ANALYSIS = functor () -> LIVE_VARIABLES_ANALYSIS + +module type MAKE_DOMINANCE_ANALYSIS = functor () -> DOMINATORS_ANALYSIS + +module type MAKE_REACHABILITY_ANALYSIS = functor () -> REACHABILITY_ANALYSIS + +module type MAKE_CONSTANT_FOLDING_ANALYSIS = functor () -> CONSTANT_FOLDING_ANALYSIS + +module type MAKE_SCHEDULER = functor () -> SCHEDULER + +module type MAKE_INTERFERENCE_GRAPH_ANALYSIS = functor () -> INTERFERENCE_GRAPH_ANALYSIS + +module type MAKE_REGISTER_ALLOCATOR = functor (T:COMPILER_TOOLBOX) -> REGISTER_ALLOCATOR + +module type MAKE_CALLCONV = functor (T:COMPILER_TOOLBOX) -> CALLCONV + +module type MAKE_CONSTANT_FOLDING = functor (T:COMPILER_TOOLBOX) -> CONSTANT_FOLDING + +module type MAKE_DEAD_CODE_ELIMINATION = functor (T:COMPILER_TOOLBOX) -> DEAD_CODE_ELIMINATION + +module type MAKE_TYPECHECKER = functor () -> TYPECHECKER + +module type MAKE_TRANSLATOR = functor () -> TRANSLATOR + +module type MAKE_JUMP_THREADING = functor () -> JUMP_THREADING + +module type MAKE_CODEGEN = functor (T:COMPILER_TOOLBOX) -> CODEGEN + +module type MAKE_HI_LOWER = functor (T:COMPILER_TOOLBOX) -> HI_LOWER + +module type MAKE_MIPS_LOWER = functor (T:COMPILER_TOOLBOX) -> MIPS_LOWER + +module type MAKE_SPILLING = functor () -> SPILLING + +module type PLUGIN = sig + + val version: string + + val make_live_variables_analysis : (module MAKE_LIVE_VARIABLES_ANALYSIS) option + + val make_dominators_analysis : (module MAKE_DOMINANCE_ANALYSIS) option + + val make_natural_loops_analysis : (module MAKE_NATURAL_LOOPS_ANALYSIS) option + + val make_spill_costs_analysis : (module MAKE_SPILL_COSTS_ANALYSIS) option + + val make_scheduler : (module MAKE_SCHEDULER) option + + val lexer_and_parser : (module LEXER_AND_PARSER) option + + val make_typechecker : (module MAKE_TYPECHECKER) option + + val make_translator : (module MAKE_TRANSLATOR) option + + val make_jump_threading : (module MAKE_JUMP_THREADING) option + + val make_constant_folding : (module MAKE_CONSTANT_FOLDING) option + + val make_hilower : (module MAKE_HI_LOWER) option + + val make_callconv : (module MAKE_CALLCONV) option + + val make_mipslower : (module MAKE_MIPS_LOWER) option + + val make_constant_folding_analysis : (module MAKE_CONSTANT_FOLDING_ANALYSIS) option + + val make_register_allocator : (module MAKE_REGISTER_ALLOCATOR) option + + val make_codegen : (module MAKE_CODEGEN) option + + val make_dead_code_elimination : (module MAKE_DEAD_CODE_ELIMINATION) option + + val make_interference_graph_analysis : (module MAKE_INTERFERENCE_GRAPH_ANALYSIS) option + + val make_spilling: (module MAKE_SPILLING) option + + val make_reachability_analysis: (module MAKE_REACHABILITY_ANALYSIS) option +end \ No newline at end of file diff --git a/source/xi_lib/plugin_register.ml b/source/xi_lib/plugin_register.ml new file mode 100644 index 0000000..da7e8a6 --- /dev/null +++ b/source/xi_lib/plugin_register.ml @@ -0,0 +1,16 @@ +open Plugin + +let register = ref [] + +let current_file = ref "" + +let register_plugin plugin = + register := (!current_file, plugin) :: !register + +module RegisterPlugin(P:PLUGIN) = struct + + let handle = (module P : PLUGIN) + + let () = register_plugin handle + +end \ No newline at end of file diff --git a/source/xi_lib/typechecker_errors.ml b/source/xi_lib/typechecker_errors.ml new file mode 100644 index 0000000..f3ee529 --- /dev/null +++ b/source/xi_lib/typechecker_errors.ml @@ -0,0 +1,257 @@ +open Ast +open Types + +type type_checking_error = + | TCERR_TypeMismatch of + { loc: location + ; expected: normal_type + ; actual: normal_type + } + + | TCERR_BindingTypeMismatch of + { loc: location + ; expected: normal_type + ; actual: normal_type + ; id: identifier + } + + | TCERR_BadNumberOfActualArguments of + { loc: location + ; expected: int + ; actual: int + } + + | TCERR_BadNumberOfReturnValues of + { loc: location + ; expected: int + ; actual: int + } + + | TCERR_UnknownIdentifier of + { loc: location + ; id: identifier + } + + | TCERR_IdentifierIsNotVariable of + { loc: location + ; id: identifier + } + + | TCERR_OtherError of + { loc: location + ; descr: string + } + + | TCERR_IdentifierIsNotCallable of + { loc: location + ; id: identifier + } + + | TCERR_NotAllControlPathsReturnValue of + { loc: location + ; id: identifier + } + + | TCERR_ExpectedFunctionReturningOneValue of + { loc: location + ; id: identifier + } + + | TCERR_ExpectedFunctionReturningManyValues of + { loc: location + ; expected: int + ; actual: int + ; id: identifier + } + + | TCERR_ProcedureCannotReturnValue of + { loc: location + } + + | TCERR_FunctionMustReturnValue of + { loc: location + } + + | TCERR_ExpectedArray of + { loc: location + ; actual: normal_type + } + + | TCERR_InvalidRedeclaration of + { loc: location + ; id: identifier + ; previous: env_type + } + + | TCERR_ShadowsPreviousDefinition of + { loc: location + ; id: identifier + } + + | TCERR_ArrayInitializationForbidden of + { loc: location } + + | TCERR_CannotInferType of + { loc: location } + +let string_of_type_checking_error = function + | TCERR_TypeMismatch {loc; actual; expected} -> + Format.sprintf "%s: error: type mismatch: expected %s; got %s" + (string_of_location loc) + (string_of_normal_type expected) + (string_of_normal_type actual) + + | TCERR_BindingTypeMismatch {loc; actual; expected; id} -> + Format.sprintf "%s: error: type mismatch: expected %s; got %s; binding %s" + (string_of_location loc) + (string_of_normal_type expected) + (string_of_normal_type actual) + (string_of_identifier id) + + | TCERR_BadNumberOfActualArguments {loc; actual; expected} -> + Format.sprintf "%s: error: bad number of actual arguments: expected %u; got %u" + (string_of_location loc) + (expected) + (actual) + + | TCERR_BadNumberOfReturnValues {loc; actual; expected} -> + Format.sprintf "%s: error: bad number of return values: expected %u; got %u" + (string_of_location loc) + (expected) + (actual) + + | TCERR_UnknownIdentifier {loc; id} -> + Format.sprintf "%s: unknown identifier: %s" + (string_of_location loc) + (string_of_identifier id) + + | TCERR_IdentifierIsNotVariable {loc; id} -> + Format.sprintf "%s: identifier is not a variable: %s" + (string_of_location loc) + (string_of_identifier id) + + | TCERR_IdentifierIsNotCallable {loc; id} -> + Format.sprintf "%s: identifier is not callable: %s" + (string_of_location loc) + (string_of_identifier id) + + | TCERR_OtherError {loc; descr} -> + Format.sprintf "%s: error: %s" + (string_of_location loc) + descr + + | TCERR_NotAllControlPathsReturnValue {loc; id} -> + Format.sprintf "%s: not all control paths return value: %s" + (string_of_location loc) + (string_of_identifier id) + + | TCERR_ExpectedFunctionReturningOneValue {loc; id} -> + Format.sprintf "%s: expected function returning exactly one value: %s" + (string_of_location loc) + (string_of_identifier id) + + | TCERR_ExpectedFunctionReturningManyValues {loc; id; expected; actual} -> + Format.sprintf "%s: expected function returning %u values, not %u: %s" + (string_of_location loc) + expected actual + (string_of_identifier id) + + | TCERR_ExpectedArray {loc; actual} -> + Format.sprintf "%s: expected array, not: %s" + (string_of_location loc) + (string_of_normal_type actual) + + | TCERR_FunctionMustReturnValue {loc} -> + Format.sprintf "%s: function must return something" + (string_of_location loc) + + | TCERR_ProcedureCannotReturnValue {loc} -> + Format.sprintf "%s: procedure cannot return value" + (string_of_location loc) + + | TCERR_InvalidRedeclaration {loc; id; previous} -> + Format.sprintf "%s: invalid redeclaration: %s: previous type: %s" + (string_of_location loc) + (string_of_identifier id) + (string_of_env_type previous) + + | TCERR_ShadowsPreviousDefinition {loc; id} -> + Format.sprintf "%s: shadows previous definition: %s" + (string_of_location loc) + (string_of_identifier id) + + | TCERR_ArrayInitializationForbidden {loc} -> + Format.sprintf "%s: array initialization is forbidden here" + (string_of_location loc) + + | TCERR_CannotInferType {loc} -> + Format.sprintf "%s: cannot infer type" + (string_of_location loc) + + module MakeErrorReporter () = struct + + let r = ref [] + + let add e = r := e :: !r + + let report_type_mismatch ~loc ~expected ~actual = + add @@ TCERR_TypeMismatch {loc;expected;actual} + + let report_binding_type_mismatch ~loc ~expected ~actual ~id = + add @@ TCERR_BindingTypeMismatch {loc;expected;actual; id} + + let report_error ~loc ~descr = + add @@ TCERR_OtherError {loc; descr} + + let report_identifier_is_not_variable ~loc ~id = + add @@ TCERR_IdentifierIsNotVariable {loc; id} + + let report_unknown_identifier ~loc ~id = + add @@ TCERR_UnknownIdentifier {loc; id} + + let report_identifier_is_not_callable ~loc ~id = + add @@ TCERR_IdentifierIsNotCallable {loc; id} + + let report_bad_number_of_arguments ~loc ~expected ~actual = + add @@ TCERR_BadNumberOfActualArguments {loc; expected; actual} + + let report_bad_number_of_return_values ~loc ~expected ~actual = + add @@ TCERR_BadNumberOfReturnValues {loc; expected; actual} + + let report_expected_function_returning_one_value ~loc ~id = + add @@ TCERR_ExpectedFunctionReturningOneValue {loc;id} + + let report_expected_function_returning_many_values ~loc ~id ~expected ~actual = + add @@ TCERR_ExpectedFunctionReturningManyValues {loc;id; expected;actual} + + let report_function_must_return_something ~loc = + add @@ TCERR_FunctionMustReturnValue {loc} + + let report_procedure_cannot_return_value ~loc = + add @@ TCERR_ProcedureCannotReturnValue {loc} + + let report_expected_array ~loc ~actual = + add @@ TCERR_ExpectedArray {loc; actual} + + let report_not_all_control_paths_return_value ~loc ~id = + add @@ TCERR_NotAllControlPathsReturnValue {loc; id} + + let report_shadows_previous_definition ~loc ~id = + add @@ TCERR_ShadowsPreviousDefinition {loc; id} + + let report_invalid_redeclaration ~loc ~id ~previous = + add @@ TCERR_InvalidRedeclaration {loc; id; previous} + + let report_array_initialization_forbidden ~loc = + add @@ TCERR_ArrayInitializationForbidden {loc} + + let report_cannot_infer ~loc = + add @@ TCERR_CannotInferType {loc} + + let flush () = + let result = List.rev !r in + r := []; + result + + + end \ No newline at end of file diff --git a/source/xi_lib/types.ml b/source/xi_lib/types.ml new file mode 100644 index 0000000..14809cc --- /dev/null +++ b/source/xi_lib/types.ml @@ -0,0 +1,31 @@ + +type normal_type + = TP_Int + | TP_Bool + | TP_Array of normal_type + +let rec string_of_normal_type = function + | TP_Int -> "int" + | TP_Bool -> "bool" + | TP_Array el -> string_of_normal_type el ^ "[]" + +type extended_type = normal_type list + +let string_of_extended_type xs = + String.concat ", " @@ List.map string_of_normal_type xs + +type result_type + = RT_Unit + | RT_Void + +type env_type + = ENVTP_Var of normal_type + | ENVTP_Fn of extended_type * extended_type + +let string_of_env_type = function + | ENVTP_Var t -> string_of_normal_type t + | ENVTP_Fn (xs, []) -> Format.sprintf "fn(%s)" + (string_of_extended_type xs) + | ENVTP_Fn (xs, rs) -> Format.sprintf "fn(%s) -> (%s)" + (string_of_extended_type xs) + (string_of_extended_type rs) \ No newline at end of file diff --git a/tests/pracownia1/parse_error.xi b/tests/pracownia1/parse_error.xi new file mode 100644 index 0000000..7bc8eee --- /dev/null +++ b/tests/pracownia1/parse_error.xi @@ -0,0 +1,75 @@ +x:int + +main(x:int y:int) +{ +} + +main() int int { + +} + +main() +{ + (x:int, y:int) = pair() +} + +pair(): int, int +{ + return (0,0) +} + +f() +{ + return 1; + x = 1 +} + +f() +{ + x = '' +} + +f() +{ + x = 'ab' +} + +f() +{ + x = ' +' +} + +f() +{ + x = '\a' +} + +f() +{ + x = "a +b" +} + +f() +{ + x = "a\tb" +} + +f() +{ + while cond return 1 +} + +f() +{ + if cond return 1 +} + +f() +{ + if cond return 1 else z = 1 +} + +//@PRACOWNIA +//@should_not_parse diff --git a/tests/pracownia1/parse_ok.xi b/tests/pracownia1/parse_ok.xi new file mode 100644 index 0000000..e4d0761 --- /dev/null +++ b/tests/pracownia1/parse_ok.xi @@ -0,0 +1,163 @@ + +f() + +f(x:int) + +f():int +{ + return 0 +} + +f(x:int, y:int) + +f(): bool + +f(): int, int + +f() +{ + x:int +} + +f() { x:int y:int } + +f() { + x:int = 1 +} + +f() +{ + return "Wroclaw" +} + +f() +{ + return 5, 10, 15, "zaraz sie zacznie" +} + +f() +{ + x:int x = 10 y = 17 +} + +f() +{ + x = 1 + 2 + 3 + x = 1 - 2 - 3 + x = 1 * 2 * 3 + x = 1 / 2 / 3 + x = 1 % 2 % 3 + x = 1 & 2 & 3 + x = 1 | 2 | 3 +} + + +f() +{ + if (x > 10) y = 1 + if x > 10 y = 1 + if x > 10 { + return "42" + } + if pred() y = 1 + if pred() & y | z x = 1 +} + +f() +{ + if (x > 10) y = 1 else z = 1 + if x > 10 y = 1 else z = 1 + if x > 10 { + return "42" + } else z = 1 + + if pred() y = 1 else { + z = 1 + } + if pred() & y | z x = 1 else { + z = 3 + } +} + +f() +{ + if x if y z = 1 else z = 2 +} + +f() +{ + while (x > 10) y = 1 + while x > 10 y = 1 + while x y = 1 + while pred() y = 1 + while pred() { + zmienna = wartosc + return + } +} + +f() +{ + g() + g(1, 2) + g(1, 2, 3) +} + +f() +{ + x:int, y:int = f() + x:int, y:int = f(1, 2) + _, y:int = f(1, 2) + _, _ = f(1, 2) + x:int, _ = f(1, 2) +} + +f() +{ + z = length("x") + z = length(x + y) + z = length(x - y) + z = length(x & y) + z = length(x / y) + z = length({1,2,3} + 1) +} + +g() +{ + z = 'a' + z = 'b' + z = '\n' + z = '\\' + z = '\'' +} + +g() +{ + z = "a" + z = "abece de" + z = "abece\nde" + z = "abece\\de" + z = "abece\"de" +} + +g(x:int[][]):bool[][] + +g(x:int[1][]):bool[][x] + +g() +{ + x:int[][][] + x:int[][][1] + x:int[2][][1] + x:int[][n][] +} + +g() +{ + x[0] = 1 + x[0][1] = 2 + x[a][b] = c[d] +} + +//@PRACOWNIA +//@stop_after parser diff --git a/tests/pracownia1/parse_operators.xi b/tests/pracownia1/parse_operators.xi new file mode 100644 index 0000000..59bbe0c --- /dev/null +++ b/tests/pracownia1/parse_operators.xi @@ -0,0 +1,14 @@ +test() +{ + x = a | b & c; + x = a & b | c & d; + x = a | b | c; + x = a < b < c; + x = a < b == c < d; + x = a < b * c == c + d < e * f + x = a * b / d % e + +} + +//@PRACOWNIA +//@stop_after parser diff --git a/tools/tester.py b/tools/tester.py new file mode 100755 index 0000000..7f48400 --- /dev/null +++ b/tools/tester.py @@ -0,0 +1,404 @@ +#!/usr/bin/env python3 + +import argparse +import glob +import os +import sys +import subprocess +import shutil + +class Configuration: + def __init__(self, xic, testdir, spim, workdir, registers_description, plugin): + self.xic = xic + self.testdir = testdir + self.spim = spim + self.workdir = workdir + self.registers_description = registers_description + self.plugin = plugin + + def printself(self): + print('Configuration:') + print(' - xic: ', self.xic) + print(' - testdir: ', self.testdir) + print(' - spim: ', self.spim) + print(' - workdir: ', self.workdir) + if self.registers_description is not None: + print(' - regdescr:', self.registers_description) + if self.plugin: + print(' - plugin:', self.plugin) + +class TestOutput: + class Status: + COMPILER_FAILURE = 0 + COMPILER_SUCCES = 1 + SPIM_FAILURE = 2 + SPIM_SUCCESS = 3 + + def __init__(self): + self.status = None + self.compiler_stdout = None + self.compiler_stderr = None + self.compiler_ok = None + self.spim_stdout = None + self.spim_stderr = None + self.spim_ok = None + + +class TestInstrumentation: + def __init__(self, test): + self.test = test + self.instrumented = False + self.expected_output = [] + self.should_parse = True + self.stop_after = None + self.should_typecheck = True + self.typechecking_errors = [] + self.selftest = None + self.env = {} + + self.parse() + self.validate() + + def content(self): + # get content of all comments started with //@ + lines = open(self.test).readlines() + lines = [ line.strip() for line in lines ] + lines = [ line for line in lines if line.startswith("//@") ] + lines = [ line[3:] for line in lines ] + return lines + + def parse(self): + content = self.content() + self.instrumented = "PRACOWNIA" in content + if not self.instrumented: + raise Exception('Test instrumentation is missing: %s' % self.test) + + for line in content: + if line.startswith("out "): + self.expected_output.append(line[4:]) + elif line == "should_not_parse": + self.should_parse = False + elif line == "should_not_typecheck": + self.should_typecheck = False + elif line.startswith("tcError "): + self.typechecking_errors.append(line[len("tcError "):]) + elif line.startswith("stop_after"): + self.stop_after = line[len("stop_after "):] + elif line.startswith("env"): + keyvalue = line[len("env "):] + keyvalue = keyvalue.split('=') + self.env[keyvalue[0]] = keyvalue[1] + elif line.startswith('selftest'): + arg = line[len('selftest'):].strip() + if arg == 'pass': + self.selftest = True + elif arg == 'fail': + self.selftest = False + else: + raise Exception("invalid @selftest directive") + + elif line == "PRACOWNIA": + pass + else: + raise Exception("invalid test instrumentation: unknown directive: " + line) + + def validate(self): + if not self.instrumented: + return + + if not self.should_parse: + if len(self.expected_output) > 0: + raise Exception("test %s marked as @should_not_parse, but expected runtime output is specified (@out)" % self.test) + if len(self.typechecking_errors) > 0: + raise Exception("test %s marked as @should_not_parse, but expected typechecking errors are specified (@tcError)" % self.test) + if not self.should_typecheck: + raise Exception("test %s marked as @should_not_parse, but expected typechecking failure is marked (@should_not_typecheck)" % self.test) + + if not self.should_typecheck: + if len(self.expected_output) > 0: + raise Exception("test %s expects typechecking failure, but expected runtime output is specified (@out)" % self.test) + + if len(self.typechecking_errors): + if len(self.expected_output) > 0: + raise Exception("test %s expects typechecking errors, but expected runtime output is specified (@out)" % self.test) + self.should_typecheck = False + +class Test: + def __init__(self, test, instrumentation): + self.test = test + self.instrumentation = instrumentation + + def expecting_parsing_error(self): + return not self.instrumentation.should_parse + + def expecting_typechecking_error(self): + return not self.instrumentation.should_typecheck + + def expecting_compilation_failure(self): + return self.expecting_parsing_error() or self.expecting_typechecking_error() + + def expecting_runtime_output(self): + return not self.expecting_compilation_failure() and not self.instrumentation.stop_after + +class ExpectationMatcher: + def __init__(self, test , output): + self.test = test + self.output = output + + def __match_output(self, stdout, expected): + actual = list(reversed(stdout)) + expected = list(reversed(expected)) + + for i in range(0, len(expected)): + if len(actual) <= i: + # nie sprawdzam tego przed petla bo chcialbym aby najpierw zmatchowal te linijki + # co sie rzeczywiscie na stdout pojawily + return False, "program output is too short, it contains %u lines, while expected out has %u" % (len(actual), len(expected)) + + expected_line = expected[i] + actual_line = actual[i] + if expected_line != actual_line: + explanation = "mismatch on line (counting from bottom): %u\nexpected: %s\nactual: %s" % (i + 1, expected_line, actual_line) + return False, explanation + return True, "" + + def __real_match(self): + # print('self.test.expecting_compilation_failure()', self.test.expecting_compilation_failure()) + # print('self.test.instrumentation.should_typecheck', self.test.instrumentation.should_typecheck) + # print('self.output.compiler_ok', self.output.compiler_ok) + if self.test.expecting_compilation_failure(): + xic_stderr = self.output.compiler_stderr.decode('utf8') + xic_stderr = xic_stderr.splitlines() + if len(xic_stderr) == 0: + xic_last_line_stderr = None + else: + xic_last_line_stderr = xic_stderr[-1].strip() + if self.output.compiler_ok: + return False, "expected compiler failure" + if self.test.expecting_parsing_error(): + if xic_last_line_stderr == "Failed: parser": + return True, "" + return False, "expected parsing error" + if self.test.expecting_typechecking_error(): + if xic_last_line_stderr == "Failed: typechecker": + return True, "" + return False, "expected typchecking error" + else: + if not self.output.compiler_ok: + return False, "program should be compiled, but compiler failed" + + if self.test.instrumentation.stop_after: + return True, "" + + if len(self.output.spim_stderr) > 0: + return False, "spim's stderr is not empty, execute program manually" + + + if self.test.expecting_runtime_output(): + if not self.output.spim_ok: + return False, "spim was not executed properly" + + if len(self.test.instrumentation.expected_output) > 0: + spim_stdout = self.output.spim_stdout.decode('utf8') + spim_stdout = spim_stdout.splitlines() + spim_stdout = [ line.strip() for line in spim_stdout ] + return self.__match_output(spim_stdout,self.test.instrumentation.expected_output) + + return True, "" + + return None, "cannot match test expectations" + + def match(self): + x_result, x_explanation = self.__real_match() + + if self.test.instrumentation.selftest == None: + result, explanation = x_result, x_explanation + else: + result = x_result == self.test.instrumentation.selftest + if result: + explanation = "" + else: + explanation = "selftest failed: expected %s, got: %s, %s" % (self.test.instrumentation.selftest, x_result, x_explanation) + + return result, explanation + +class TestRawExecutor: + + def __init__(self, conf, test, env, run_spim, stop_point): + self.conf = conf + self.test = test + self.env = env + self.output_file = os.path.join(conf.workdir, 'main.s') + self.test_output = TestOutput() + self.run_spim = run_spim + self.stop_point = stop_point + + def execute(self): + self.prepare_env() + ok, stdout, stderr = self.compile_program() + self.test_output.compiler_stdout = stdout + self.test_output.compiler_stderr = stderr + self.test_output.compiler_ok = ok + if not ok or not self.run_spim or self.stop_point: + self.clean_env() + return self.test_output + + ok, stdout, stderr = self.execute_program() + self.test_output.spim_stdout = stdout + self.test_output.spim_stderr = stderr + self.test_output.spim_ok = ok + self.clean_env() + + return self.test_output + + def compile_program(self): + xs = [self.conf.xic, '-o', self.output_file] + if self.stop_point: + xs.append('--stop-after') + xs.append(self.stop_point) + if self.conf.registers_description is not None: + xs.append('--registers-description') + xs.append(self.conf.registers_description) + if self.conf.plugin is not None: + xs.append('--plugin') + xs.append(self.conf.plugin) + + xs.append('--xi-log') + xs.append(os.path.join(self.conf.workdir, 'xilog')) + xs.append(self.test) + env = dict(self.env) + return self.__call(xs, env) + + def execute_program(self): + return self.__call([self.conf.spim, '-file', self.output_file]) + + def prepare_env(self): + shutil.rmtree(self.conf.workdir, ignore_errors=True) + os.makedirs(self.conf.workdir) + + def clean_env(self): + shutil.rmtree(self.conf.workdir, ignore_errors=True) + + def __call(self, xs, extenv={}): + env = os.environ + for k in extenv: + env[k] = extenv[k] + + try: + p = subprocess.Popen(xs, stdin=None, stdout=subprocess.PIPE, stderr=subprocess.PIPE, env=env) + stdin, stdout = p.communicate(timeout=5) + status = p.returncode == 0 + return (status, stdin, stdout) + except subprocess.TimeoutExpired: + return (False, [], []) + except Exception: + # potem cos tu doklepie aby wykonywarka testow mogla sie kapnac, ze to nie test wykryl blad + # a cos innego + return (False, [], []) + +class TestExecutor: + def __init__(self, test, conf): + self.test = test + self.conf = conf + + def execute(self): + try: + run_spim = self.test.expecting_runtime_output() + stop_point = None + if not run_spim: + if self.test.expecting_parsing_error(): + stop_point = "parser" + elif self.test.expecting_typechecking_error(): + stop_point = "typechecker" + elif self.test.instrumentation.stop_after: + stop_point = self.test.instrumentation.stop_after + + rawExecutor = TestRawExecutor(self.conf, self.test.test, self.test.instrumentation.env, run_spim, stop_point) + test_output = rawExecutor.execute() + matcher = ExpectationMatcher(self.test, test_output) + return matcher.match() + except Exception as e: + raise e + return None, "internal error: " + str(e) + + +class TestRepository: + def __init__(self, testdirs): + self.tests = [] + self.collect_tests(testdirs) + + def collect_tests(self, testdirs): + testfiles = [] + for testdir in testdirs: + for path, _, files in os.walk(testdir): + for file in files: + if file.endswith(".xi"): + testfiles.append(os.path.join(path, file)) + testfiles = list(sorted(testfiles)) + + for testfile in testfiles: + instrumentation = TestInstrumentation(testfile) + test = Test(testfile, instrumentation) + self.tests.append(test) + + def gen(self): + for t in self.tests: + yield t + +class Application: + def __init__(self): + args = self.create_argparse().parse_args() + self.conf = Configuration(xic=args.xic, + testdir=args.testdir, + spim=args.spim, + workdir=args.workdir, + registers_description=args.registers_description, + plugin=args.plugin) + + + def create_argparse(self): + parser = argparse.ArgumentParser(description='Xi tester') + parser.add_argument('--xic', help='path to xi binary', default='./_build/install/default/bin/xi', type=str) + parser.add_argument('--spim', help='path to spim binary', default='spim', type=str) + parser.add_argument('--testdir', help='path to test directory', default='./tests', type=str) + parser.add_argument('--workdir', help='working directory', default='workdir', type=str) + parser.add_argument('--registers-description', help='xi --registers-description', default=None, type=str) + parser.add_argument('--plugin', help='xi --plugin', type=str) + return parser + + def run(self): + print('Xi tester') + self.conf.printself() + self.test_repository = TestRepository([self.conf.testdir]) + passed_tests = [] + failed_tests = [] + inconclusive_tests = [] + for test in self.test_repository.gen(): + print('==> running test', test.test) + executor = TestExecutor(test, self.conf) + result, explanation = executor.execute() + + if result == None: + inconclusive_tests.append(test) + status = "inconclusive: " + explanation + elif result: + passed_tests.append(test) + status = "pass" + elif not result: + failed_tests.append(test) + status = "fail: " + explanation + + print('--- result:', status) + + total = len(passed_tests) + len(failed_tests) + len(inconclusive_tests) + + print('===================') + print('Total: ', total) + print('Passed:', len(passed_tests)) + print('Inconc:', len(inconclusive_tests)) + print('Failed:', len(failed_tests)) + for test in failed_tests: + print(' -', test.test) + + +Application().run() diff --git a/xi.opam b/xi.opam new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/xi.opam diff --git a/xi_lib.opam b/xi_lib.opam new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/xi_lib.opam diff --git a/xisdk/mod_uwr.cma b/xisdk/mod_uwr.cma new file mode 100644 index 0000000..5e94a9d --- /dev/null +++ b/xisdk/mod_uwr.cma Binary files differ |