summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaweł Dybiec <pdybiec@stud.cs.uni.wroc.pl>2018-10-30 15:32:56 +0100
committerPaweł Dybiec <pdybiec@stud.cs.uni.wroc.pl>2018-10-30 15:32:56 +0100
commitb798ac29c37299b2f761243ae92ab8f7c4c4d7f1 (patch)
treeeb9b9cc9be294fe5bd3acf9a342098ffc0ea06e5
Initial commit
-rw-r--r--Makefile28
-rw-r--r--dune-project2
-rw-r--r--dune-workspace0
-rw-r--r--mod_student.opam0
-rw-r--r--source/mod_student/.merlin7
-rw-r--r--source/mod_student/dune21
-rw-r--r--source/mod_student/lexer.mll79
-rw-r--r--source/mod_student/parser.mly70
-rw-r--r--source/mod_student/plugin.ml61
-rw-r--r--source/xi/.merlin15
-rw-r--r--source/xi/dune15
-rw-r--r--source/xi/invariants.ml146
-rw-r--r--source/xi/parser_wrapper.ml42
-rw-r--r--source/xi/pipeline.ml137
-rw-r--r--source/xi/plugin_manager.ml245
-rw-r--r--source/xi/xi.ml82
-rw-r--r--source/xi_lib/.merlin5
-rw-r--r--source/xi_lib/analysis.ml77
-rw-r--r--source/xi_lib/analysis_domain.ml135
-rw-r--r--source/xi_lib/analysis_visualizer.ml295
-rw-r--r--source/xi_lib/ast.ml288
-rw-r--r--source/xi_lib/ast_printer.ml271
-rw-r--r--source/xi_lib/ast_rawprinter.ml313
-rw-r--r--source/xi_lib/dune9
-rw-r--r--source/xi_lib/hardcoded.ml122
-rw-r--r--source/xi_lib/hashset.ml30
-rw-r--r--source/xi_lib/iface.ml199
-rw-r--r--source/xi_lib/ir.ml288
-rw-r--r--source/xi_lib/ir_arch.ml107
-rw-r--r--source/xi_lib/ir_utils.ml668
-rw-r--r--source/xi_lib/logger.ml170
-rw-r--r--source/xi_lib/measure.ml8
-rw-r--r--source/xi_lib/mips32.ml217
-rw-r--r--source/xi_lib/mygraph.ml155
-rw-r--r--source/xi_lib/parser_utils.ml7
-rw-r--r--source/xi_lib/plugin.ml85
-rw-r--r--source/xi_lib/plugin_register.ml16
-rw-r--r--source/xi_lib/typechecker_errors.ml257
-rw-r--r--source/xi_lib/types.ml31
-rw-r--r--tests/pracownia1/parse_error.xi75
-rw-r--r--tests/pracownia1/parse_ok.xi163
-rw-r--r--tests/pracownia1/parse_operators.xi14
-rwxr-xr-xtools/tester.py404
-rw-r--r--xi.opam0
-rw-r--r--xi_lib.opam0
-rw-r--r--xisdk/mod_uwr.cmabin0 -> 1183174 bytes
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