summary refs log tree commit diff
path: root/source/xi
diff options
context:
space:
mode:
Diffstat (limited to 'source/xi')
-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
7 files changed, 682 insertions, 0 deletions
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