Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • theo.putegnat/infosec-ecomp
  • damien.armillon/infosec-ecomp
  • mouhamed.sougou/infosec-ecomp
  • cidre-public/compilation/infosec-ecomp
4 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 837 additions and 128 deletions
src/report.ml
View file @ a16795a0
open Options
open Utils
type html_node =
| Img of string
......@@ -23,17 +25,185 @@ let add_to_report id title content =
let make_report filename report () =
let html = open_out (filename ^ ".html") in
Printf.fprintf html "<ul id=\"top\">";
Printf.fprintf html "\
<html>\n\
<head>\n\
<link rel=\"stylesheet\" href=\"https://www.w3schools.com/w3css/4/w3.css\">\n\
<script src=\"https://kit.fontawesome.com/1f5d81749b.js\" crossorigin=\"anonymous\"></script>\n\
<style type=\"text/css\">\n\
a.anchor {\n\
display: block; \
position: relative; \
left: -250px; \
visibility: hidden;\
}\n\
</style>\n\
</head>\n\
<body>\n\
";
Printf.fprintf html "<div \
class=\"w3-container w3-cell\" \
style=\"position: fixed; z-index: 1; top: 0; bottom: 0; width: 250px; overflow-y: scroll;\"\
>\n <ul class=\"w3-ul\">\n";
let t = Unix.time () in
let tm = Unix.localtime t in
let open Unix in
Printf.fprintf html "<li>%02d/%02d/%04d - %02dh%02d</li>"
tm.tm_mday
(tm.tm_mon + 1)
(tm.tm_year + 1900)
tm.tm_hour
tm.tm_min
;
Printf.fprintf html " <li><a href=\"../results.html\"><i class=\"fa fa-home\"></i> Results</a></li>\n";
List.iter
(fun { sect_id; sect_title } ->
Printf.fprintf html "<li><a href=\"#%s\">%s</a></li>\n" sect_id sect_title
(fun { sect_id; sect_title; _ } ->
Printf.fprintf html " <li><a href=\"#%s\">%s</a></li>\n" sect_id sect_title
)
!report;
Printf.fprintf html "</ul>";
Printf.fprintf html "</ul></div><div \
class=\"w3-container w3-cell-row\" \
style=\"margin-left: 250px;\"\
><a class=\"anchor\" id=\"top\"></a>";
List.iter
(fun { sect_id; sect_title; sect_content } ->
Printf.fprintf html "<fieldset><h3 id=\"%s\"><a href=\"#top\">&uarr;</a> %s</h3>%a</fieldset>\n" sect_id sect_title print_html sect_content
Printf.fprintf html "<fieldset>\n\
<a class=\"anchor\" id=\"%s\"></a>\n\
<h3><a href=\"#top\">&uarr;</a> %s</h3>\n\
%a\n\
</fieldset>\n" sect_id sect_title print_html sect_content
)
!report;
Printf.fprintf html "\
</div>\n\
</body>\n\
</html>";
close_out html;
()
let call_dot report_sectid report_secttitle file () : unit =
if not !Options.no_dot
then begin
let r = Sys.command (Format.sprintf "dot -Tsvg %s -o %s.svg" file file) in
add_to_report report_sectid report_secttitle (Img (Filename.basename file^".svg"));
ignore r
end
(* *)
type run_result = {
step: string;
retval: int option;
output: string;
error: string option;
time: float;
}
type compile_result = {
step: string;
error: string option;
data: Yojson.t
}
type result = RunRes of run_result
| CompRes of compile_result
let results : result list ref = ref []
let record_compile_result ?error:(error=None) ?data:(data=[]) step =
let data = if not !Options.nostats then `List data else `Null in
results := !results @ [CompRes { step; error; data}]
let kill pid sign =
try Unix.kill pid sign with
| Unix.Unix_error (e,f,p) ->
begin match e with
| ESRCH -> ()
| _ -> Printf.printf "%s\n" ((Unix.error_message e)^"|"^f^"|"^p)
end
| e -> raise e
let run_exn_to_error f x =
try f x with
| e -> Error (Printexc.to_string e)
let timeout (f: 'a -> 'b res) (arg: 'a) (time: float) : ('b * string) res =
let pipe_r,pipe_w = Unix.pipe () in
(match Unix.fork () with
| 0 ->
let r =
run_exn_to_error f arg >>= fun v ->
OK (v, Format.flush_str_formatter ()) in
let oc = Unix.out_channel_of_descr pipe_w in
Marshal.to_channel oc r [];
close_out oc;
exit 0
| pid0 ->
(match Unix.fork () with
| 0 -> Unix.sleepf time;
kill pid0 Sys.sigkill;
let oc = Unix.out_channel_of_descr pipe_w in
Marshal.to_channel oc (Error (Printf.sprintf "Timeout after %f seconds." time)) [];
close_out oc;
exit 0
| _ -> let ic = Unix.in_channel_of_descr pipe_r in
let result = Marshal.from_channel ic in
result ))
let run step flag eval p =
if flag then begin
let starttime = Unix.gettimeofday () in
let res = timeout
(fun (p, params) -> eval Format.str_formatter p !heapsize params)
(p, !params)
!Options.timeout in
let timerun = Unix.gettimeofday () -. starttime in
let rres = { step ; retval = None; output=""; error = None; time = timerun} in
let rres =
begin match res with
| OK (v, output) -> { rres with retval = v; output }
| Error msg -> { rres with error = Some msg }
end in
results := !results @ [RunRes rres];
add_to_report step ("Run " ^ step) (
Paragraph
(
Printf.sprintf "With parameters : [%s]<br>\n" (String.concat"," (List.map string_of_int !params))
^ Printf.sprintf "Mem size : %d bytes<br>\n" !heapsize
^ Printf.sprintf "Return value : %s<br>\n" (match rres.retval with | Some v -> string_of_int v | _ -> "none")
^ Printf.sprintf "Output : <pre style=\"padding: 1em; background-color: #ccc;\">%s</pre>\n" rres.output
^
(match rres.error with
| Some msg -> Printf.sprintf "Error : <pre style=\"padding: 1em; background-color: #fcc;\">\n%s</pre>\n" msg
| _ -> "")
^ Printf.sprintf "Time : %f seconds<br>\n" timerun
)
)
end
let json_output_string () =
let jstring_of_ostring o =
match o with
| None -> `Null
| Some s -> `String s
in
let j = `List (List.map (function
| RunRes { step; retval; output; error; time } ->
`Assoc [("runstep",`String step);
("retval", match retval with Some r -> `Int r | None -> `Null);
("output", `String output);
("error", jstring_of_ostring error);
("time", `Float time)
]
| CompRes { step; error; data } ->
`Assoc [("compstep",`String step);
("error", jstring_of_ostring error);
("data", data)
]
) !results) in
(Yojson.pretty_to_string j)
src/riscv.ml
View file @ a16795a0
......@@ -7,6 +7,7 @@ open Ltl_print
open Utils
open Prog
open Options
open Archi
(* This file performs the translation from LTL programs to RISC-V assembly
programs. The languages are basically the same, so the only thing to do here
......@@ -43,27 +44,19 @@ let print_binop (b: binop) =
| Elang.Emul -> "mul"
| Elang.Emod -> "remu"
| Elang.Exor -> "xor"
| Elang.Ediv -> "div"
| Elang.Ediv -> "divu"
| Elang.Esub -> "sub"
| Elang.Eclt -> "slt"
| Elang.Ecle -> "sle"
| Elang.Ecgt -> "sgt"
| Elang.Ecge -> "sge"
| Elang.Eceq -> "seq"
| Elang.Ecne -> "sne"
| _ -> failwith "Unexpected binop"
let print_unop (u: unop) =
match u with
| Elang.Eneg -> "neg"
let instrsuffix_of_size sz =
match !Archi.archi, sz with
| _, 1 -> 'b'
| _, 4 -> 'w'
| A64, 8 -> 'd'
| _, _ ->
failwith (Format.sprintf "Impossible write size (%d) in archi (%d)"
sz !Archi.nbits)
match sz with
| MAS1 -> 'b'
| MAS4 -> 'w'
| MAS8 -> 'd'
let dump_riscv_instr oc (i: ltl_instr) =
match i with
......@@ -72,18 +65,48 @@ let dump_riscv_instr oc (i: ltl_instr) =
| LSubi(rd, rs, i) ->
Format.fprintf oc "addi %s, %s, %d\n" (print_reg rd) (print_reg rs) (-i)
| LBinop(b, rd, rs1, rs2) ->
(* TODO *)
Format.fprintf oc "%s %s, %s, %s\n"
begin match b with
| Elang.Eclt ->
Format.fprintf oc "slt %s, %s, %s\n"
(print_reg rd) (print_reg rs1) (print_reg rs2)
| Elang.Ecgt ->
Format.fprintf oc "slt %s, %s, %s\n"
(print_reg rd) (print_reg rs2) (print_reg rs1)
| Elang.Ecle ->
(* 'rd <- rs1 <= rs2' == 'rd <- rs2 < rs1; rd <- seqz rd' *)
Format.fprintf oc "slt %s, %s, %s\n"
(print_reg rd) (print_reg rs2) (print_reg rs1);
Format.fprintf oc "seqz %s, %s\n"
(print_reg rd) (print_reg rd)
| Elang.Ecge ->
Format.fprintf oc "slt %s, %s, %s\n"
(print_reg rd) (print_reg rs1) (print_reg rs2);
Format.fprintf oc "seqz %s, %s\n"
(print_reg rd) (print_reg rd)
| Elang.Eceq ->
Format.fprintf oc "sub %s, %s, %s\n"
(print_reg rd) (print_reg rs1) (print_reg rs2);
Format.fprintf oc "seqz %s, %s\n"
(print_reg rd) (print_reg rd)
| Elang.Ecne ->
Format.fprintf oc "sub %s, %s, %s\n"
(print_reg rd) (print_reg rs1) (print_reg rs2);
Format.fprintf oc "snez %s, %s\n"
(print_reg rd) (print_reg rd)
| _ -> Format.fprintf oc "%s %s, %s, %s\n"
(print_binop b) (print_reg rd) (print_reg rs1) (print_reg rs2)
end
| LUnop(u, rd, rs) ->
Format.fprintf oc "%s %s, %s\n"
(print_unop u) (print_reg rd) (print_reg rs)
(print_unop u) (print_reg rd) (print_reg rs)
| LStore(rt, i, rs, sz) ->
let sz = instrsuffix_of_size sz in
Format.fprintf oc "s%c %s, %d(%s)\n"
(instrsuffix_of_size sz) (print_reg rs) i (print_reg rt)
sz (print_reg rs) i (print_reg rt)
| LLoad(rd, rt, i, sz) ->
let sz = (instrsuffix_of_size sz) in
Format.fprintf oc "l%c %s, %d(%s)\n"
(instrsuffix_of_size sz) (print_reg rd) i (print_reg rt)
sz (print_reg rd) i (print_reg rt)
| LMov(rd, rs) ->
Format.fprintf oc "mv %s, %s\n" (print_reg rd) (print_reg rs)
| LLabel l ->
......@@ -103,58 +126,46 @@ let dump_riscv_fun oc (fname , lf) =
Format.fprintf oc "%s:\n" fname;
List.iter (dump_riscv_instr oc) lf.ltlfunbody
let riscv_load_args oc =
let nargs = [1;2;3;4;5;6;7;8] in
(* for each arg in [1..8]:
a0 <- arg
call load_int_arg
call atoi
sd a0, -8*arg(fp)
*)
let l1 = nargs |>
List.map (fun i ->
[LConst(reg_a0, i);
LCall("load_int_arg");
LCall("atoi");
LStore(reg_fp, - !Archi.wordsize*i,
reg_a0, !Archi.wordsize)
]) in
(* for each arg in [1..8]
ld a{arg-1}, -8*arg(fp)
*)
let l2 = nargs |>
List.map (fun i ->
[LLoad(starting_arg_register + i - 1, reg_fp,
- !Archi.wordsize*i, !Archi.wordsize)]) in
(l1 @ l2) |> List.concat |> List.iter (fun i -> dump_riscv_instr oc i)
let riscv_fun_load_arg oc () =
("load_int_arg",{
ltlfunargs = 0;
(*
t0 <- Archi.wordsize (in this example 8)
mul a0, a0, t0
add t0, fp, a0
ld a0, 8(t0)
jmpr ra
*)
ltlfunbody = [LConst(reg_t0, !Archi.wordsize);
LBinop(Emul, reg_ret, reg_ret, reg_t0);
LBinop(Eadd, reg_t0, reg_fp, reg_ret);
LLoad(reg_ret, reg_t0, !Archi.wordsize, !Archi.wordsize);
LJmpr reg_ra
];
ltlfuninfo = [];
ltlregalloc = []
}) |> dump_riscv_fun oc
let riscv_load_args target oc : unit =
(match target with
| Linux -> LLoad(reg_s1, reg_sp, 0, archi_mas ()) :: (* s1 <- argc *)
LAddi(reg_s2, reg_sp, (Archi.wordsize ())) :: []
| Xv6 -> LMov(reg_s1, reg_a0) ::
LMov(reg_s2, reg_a1) :: []) @
LConst(reg_s3, 1) ::
LSubi(reg_sp, reg_sp, 72) ::
LLabel "Lloop" ::
LBranch(Rceq, reg_s3, reg_s1, "Lendargs") ::
LMov(reg_a0, reg_t4) ::
LAddi(reg_s4, reg_s3, 0) ::
LConst(reg_t1, (Archi.wordsize ())) ::
LBinop(Emul, reg_s4, reg_s4, reg_t1) ::
LBinop(Eadd, reg_t3, reg_s4, reg_s2) ::
LLoad(reg_a0, reg_t3, 0, archi_mas ()) ::
LCall "atoi" ::
LBinop(Esub, reg_s4, reg_fp, reg_s4) ::
LStore(reg_s4, 0, reg_a0, archi_mas ()) ::
LAddi(reg_s3, reg_s3, 1) ::
LJmp "Lloop" ::
LLabel "Lendargs" ::
LLoad(reg_a0, reg_fp, -8, archi_mas ()) ::
LLoad(reg_a1, reg_fp, -16, archi_mas ()) ::
LLoad(reg_a2, reg_fp, -24, archi_mas ()) ::
LLoad(reg_a3, reg_fp, -32, archi_mas ()) ::
LLoad(reg_a4, reg_fp, -40, archi_mas ()) ::
LLoad(reg_a5, reg_fp, -48, archi_mas ()) ::
LLoad(reg_a6, reg_fp, -56, archi_mas ()) ::
LLoad(reg_a7, reg_fp, -64, archi_mas ()) ::
[] |>
List.iter (dump_riscv_instr oc)
let rv_store () =
Format.sprintf "s%c" !Archi.instrsuffix
Format.sprintf "s%c" (Archi.instrsuffix ())
let rv_load () =
Format.sprintf "l%c" !Archi.instrsuffix
Format.sprintf "l%c" (Archi.instrsuffix ())
let riscv_prelude oc =
let riscv_prelude target oc =
Format.fprintf oc ".include \"syscall_numbers.s\"\n";
Format.fprintf oc ".globl _start\n";
Format.fprintf oc "_start:\n";
Format.fprintf oc " lui gp, %%hi(_heap_start)\n";
......@@ -162,21 +173,19 @@ let riscv_prelude oc =
Format.fprintf oc " addi t0, gp, 8\n";
Format.fprintf oc " %s t0, 0(gp)\n" (rv_store ());
Format.fprintf oc " mv s0, sp\n";
Format.fprintf oc " add sp, sp, -72\n";
riscv_load_args oc;
riscv_load_args target oc ;
Format.fprintf oc "jal ra, main\n";
Format.fprintf oc "mv s0, a0\n";
Format.fprintf oc "jal ra, println\n";
Format.fprintf oc "mv a0, s0\n";
Format.fprintf oc "jal ra, print_int\n";
Format.fprintf oc "jal ra, println\n";
Format.fprintf oc "addi a7, zero, 93\n";
Format.fprintf oc "addi a7, zero, SYSCALL_EXIT\n";
Format.fprintf oc "ecall\n"
let dump_riscv_prog oc lp =
if !nostart then () else riscv_prelude oc;
let dump_riscv_prog target oc lp : unit =
(if !nostart then () else riscv_prelude target oc);
Format.fprintf oc ".global main\n";
List.iter (function
(fname, Gfun f) -> dump_riscv_fun oc (fname,f)
) lp;
riscv_fun_load_arg oc ()
) lp
src/rtl.ml
View file @ a16795a0
open Batteries
open BatList
open Elang
open Cfg
open Utils
open Prog
type reg = int
......@@ -24,3 +21,19 @@ type rtl_fun = { rtlfunargs: reg list;
rtlfunentry: int;
rtlfuninfo: (string*reg) list
}
let written_rtl_regs_instr (i: rtl_instr) =
match i with
| Rbinop (_, rd, _, _)
| Runop (_, rd, _)
| Rconst (rd, _)
| Rmov (rd, _) -> Set.singleton rd
| Rprint _
| Rret _
| Rlabel _
| Rbranch (_, _, _, _)
| Rjmp _ -> Set.empty
let written_rtl_regs (l: rtl_instr list) =
List.fold_left (fun acc i -> Set.union acc (written_rtl_regs_instr i))
Set.empty l
src/rtl_gen.ml
View file @ a16795a0
......@@ -4,6 +4,9 @@ open Cfg
open Rtl
open Prog
open Utils
open Report
open Rtl_print
open Options
(* Une partie de la génération de RTL consiste à allouer les variables dans des
pseudo-registres RTL.
......@@ -25,10 +28,9 @@ open Utils
*)
let find_var (next_reg, var2reg) v =
begin match List.assoc_opt v var2reg with
match List.assoc_opt v var2reg with
| Some r -> (r, next_reg, var2reg)
| None -> (next_reg, next_reg + 1, assoc_set var2reg v next_reg)
end
(* [rtl_instrs_of_cfg_expr (next_reg, var2reg) e] construit une liste
d'instructions RTL correspondant à l'évaluation d'une expression E.
......@@ -52,9 +54,12 @@ let is_cmp_op =
| Ecne -> Some Rcne
| _ -> None
let is_cmp (e: expr) =
let rtl_cmp_of_cfg_expr (e: expr) =
match e with
| Ebinop (b, e1, e2) -> (match is_cmp_op b with | None -> (Rcne, e, Eint 0) | Some rop -> (rop, e1, e2))
| Ebinop (b, e1, e2) ->
(match is_cmp_op b with
| None -> (Rcne, e, Eint 0)
| Some rop -> (rop, e1, e2))
| _ -> (Rcne, e, Eint 0)
......@@ -87,3 +92,9 @@ let rtl_of_gdef funname = function
Gfun f -> Gfun (rtl_instrs_of_cfg_fun funname f)
let rtl_of_cfg cp = List.map (fun (s, gd) -> (s, rtl_of_gdef s gd)) cp
let pass_rtl_gen cfg =
let rtl = rtl_of_cfg cfg in
dump !rtl_dump dump_rtl_prog rtl
(fun file () -> add_to_report "rtl" "RTL" (Code (file_contents file)));
OK rtl
src/rtl_print.ml
View file @ a16795a0
......@@ -17,8 +17,15 @@ let print_cmpop (r: rtl_cmp) =
| Rceq -> "=="
| Rcne -> "!=")
let dump_rtl_instr name (live_in, live_out) oc (i: rtl_instr) =
let dump_rtl_instr name (live_in, live_out) ?(endl="\n") oc (i: rtl_instr) =
let print_node s = Format.sprintf "%s_%d" name s in
let dump_liveness live where =
match live with
Some live -> Format.fprintf oc "// Live %s : { %s }\n" where (String.concat ", " (Set.to_list (Set.map string_of_int live)))
| None -> ()
in
dump_liveness live_in "before";
begin match i with
| Rbinop (b, rd, rs1, rs2) ->
Format.fprintf oc "%s <- %s(%s, %s)" (print_reg rd) (dump_binop b) (print_reg rs1) (print_reg rs2)
......@@ -35,7 +42,8 @@ let dump_rtl_instr name (live_in, live_out) oc (i: rtl_instr) =
| Rprint r -> Format.fprintf oc "print %s" (print_reg r)
| Rlabel n -> Format.fprintf oc "%s_%d:" name n
end;
Format.fprintf oc "\n"
Format.fprintf oc "%s" endl;
dump_liveness live_out "after"
let dump_rtl_node name lives =
print_listi (fun i ->
......@@ -44,6 +52,7 @@ let dump_rtl_node name lives =
None -> (None, None)
| Some (lin, lout) ->
Hashtbl.find_option lin i, Hashtbl.find_option lout i)
~endl:"\n"
) "" "" ""
let dump_rtl_fun oc rtlfunname ({ rtlfunargs; rtlfunbody; rtlfunentry }: rtl_fun) =
......
src/symbols.ml
View file @ a16795a0
open BatPrintf
open Batteries
open Utils
let string_of_position pos =
let open Lexing in
......@@ -55,6 +53,7 @@ type token =
| SYM_PRINT
| SYM_EXTERN
| SYM_INCLUDE of string
| SYM_AMPERSAND
let string_of_symbol = function
| SYM_EOF -> "SYM_EOF"
......@@ -103,3 +102,4 @@ let string_of_symbol = function
| SYM_PRINT -> "SYM_PRINT"
| SYM_EXTERN -> "SYM_EXTERN"
| SYM_INCLUDE(s) -> Printf.sprintf "SYM_INCLUDE(%s)" s
| SYM_AMPERSAND -> "SYM_AMPERSAND"
src/test_lexer.ml
View file @ a16795a0
......@@ -4,20 +4,45 @@ open Batteries
open Utils
open Symbols
let nfa_accepts (n: nfa) (w: char list) : bool =
let rec trav vis s =
if Set.mem s vis then vis
else let en = List.filter_map (fun (oa, n) -> if oa = None then Some n else None) (n.nfa_step s) in
List.fold_left trav (Set.add s vis) en in
let ec s = trav Set.empty s in
let ecs ls = Set.fold (fun q -> Set.union (ec q)) ls Set.empty in
let rec walk (q: int set) (w: char list) =
let q = ecs q in
match w with
| [] -> Set.exists (fun q -> List.mem q (List.map fst n.nfa_final)) q
| c::w ->
let q' =
Set.fold Set.union (Set.map (fun q ->
(List.filter_map
(fun (cso,q') ->
match cso with
| None -> None
| Some cs -> if Set.mem c cs then Some q' else None
)
(n.nfa_step q)) |> Set.of_list
) q) Set.empty
in walk q' w in
walk (Set.of_list n.nfa_initial) w
let () =
let lowercase_letters = "abcdefghijklmnopqrstuvwxyz" in
let uppercase_letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" in
let digits = "0123456789" in
let other_characters = "?!=<>_ ;,{}()[]-+*/%\n\t" in
let alphabet = char_list_of_string (lowercase_letters ^ uppercase_letters ^ digits ^ other_characters) in
let letter_regexp = char_range (char_list_of_string (uppercase_letters ^ lowercase_letters)) in
let digit_regexp = char_range (char_list_of_string digits) in
let keyword_regexp s = str_regexp (char_list_of_string s) in
let regexp_list = [
(keyword_regexp "while", fun s -> Some (SYM_WHILE));
(keyword_regexp "if", fun s -> Some (SYM_IF));
] in
(Cat(letter_regexp,
Star(identifier_material)),
fun s -> Some (SYM_IDENTIFIER s));
] in
(* Décommentez la ligne suivante pour tester sur la vraie liste d'expressions
régulières. *)
(* let regexp_list = list_regexp in *)
List.iteri
(fun i (rg, _) -> Printf.printf "%d: %s\n" i (string_of_regexp rg))
regexp_list;
......@@ -35,4 +60,131 @@ let () =
dfa_to_dot oc dfa alphabet;
close_out oc;
let n =
{
nfa_states = [1; 2; 3; 4] ;
nfa_initial = [1] ;
nfa_final = [(3, fun s -> None); (4, fun s -> None)];
nfa_step = fun q ->
match q with
| 1 -> [(Some (Set.singleton '0'), 2); (None, 3)]
| 2 -> [(Some (Set.singleton '1'), 2); (Some (Set.singleton '1'), 4)]
| 3 -> [(Some (Set.singleton '0'), 4); (None, 2)]
| 4 -> [(Some (Set.singleton '0'), 2)]
| _ -> []
} in
let expect_set str s_got s_exp =
if Set.equal s_got s_exp
then Printf.printf "[OK] %s\n" str
else Printf.printf "[KO] %s : got %s, expected %s\n" str (string_of_int_set s_got)
(string_of_int_set s_exp) in
let ec1 = epsilon_closure n 1 in
let ec2 = epsilon_closure n 2 in
let ec3 = epsilon_closure n 3 in
let ec4 = epsilon_closure n 4 in
expect_set "epsilon_closure 1" ec1 (Set.of_list [1;2;3]);
expect_set "epsilon_closure 2" ec2 (Set.of_list [2]);
expect_set "epsilon_closure 3" ec3 (Set.of_list [2;3]);
expect_set "epsilon_closure 4" ec4 (Set.of_list [4]);
expect_set "dfa_initial_state" (dfa_initial_state n) (Set.of_list [1;2;3]);
let string_of_opt_tok ot =
match ot with
None -> "None"
| Some t -> Printf.sprintf "Some (%s)" (string_of_symbol t)
in
let expect_token_option str to_got to_exp =
if to_got = to_exp
then Printf.printf "[OK] %s\n" str
else Printf.printf "[KO] %s : got %s, expected %s\n" str (string_of_opt_tok to_got)
(string_of_opt_tok to_exp)
in
expect_token_option "min_priority 1" (min_priority [SYM_EOF; SYM_IDENTIFIER "bla"; SYM_WHILE]) (Some SYM_WHILE);
expect_token_option "min_priority 2" (min_priority [SYM_EOF; SYM_IDENTIFIER "bla"]) (Some (SYM_IDENTIFIER "bla"));
expect_token_option "min_priority 3" (min_priority [SYM_EOF; SYM_WHILE]) (Some SYM_WHILE);
expect_token_option "min_priority 4" (min_priority []) None;
let set_incl s1 s2 =
Set.for_all (fun s -> Set.exists (Set.equal s) s2) s1
in
let set_eq s1 s2 = set_incl s1 s2 && set_incl s2 s1 in
let string_of_int_set_set s =
Set.map (fun s ->
Printf.sprintf "{%s}" (String.concat "," (Set.to_list (Set.map string_of_int s)))
) s
|> Set.to_list
|> String.concat ", "
|> Printf.sprintf "{%s}"
in
let expect_set_set str (set_got : int set set) (set_exp : int set set) =
if set_eq set_got set_exp
then Printf.printf "[OK] %s\n" str
else Printf.printf "[KO] %s : got %s, expected %s\n" str
(string_of_int_set_set set_got)
(string_of_int_set_set set_exp)
in
let table = Hashtbl.create 10 in
build_dfa_table table n (dfa_initial_state n);
expect_set_set "dfa states" (Hashtbl.keys table |> Set.of_enum) (Set.of_list [Set.of_list [1;2;3]; Set.of_list [2;4]; Set.of_list [2]]);
let expect_nfa_accepts n s b =
let r = nfa_accepts n (char_list_of_string s) in
if r = b
then Printf.printf "[OK] nfa_accepts %s = %b\n" s r
else Printf.printf "[KO] nfa_accepts %s = %b\n" s r
in
Printf.printf "*** NFA n1 : 'hello'\n";
let n1, f1 = nfa_of_regexp (keyword_regexp "hello") 1 (fun _ -> None) in
expect_nfa_accepts n1 "hello" true;
expect_nfa_accepts n1 "bonjour" false;
Printf.printf "*** NFA n2 : 'bonjour'\n";
let n2, f2 = nfa_of_regexp (keyword_regexp "bonjour") f1 (fun _ -> None) in
expect_nfa_accepts n2 "hello" false;
expect_nfa_accepts n2 "bonjour" true;
Printf.printf "*** NFA n3 : n1 | n2\n";
let n3 = alt_nfa n1 n2 in
expect_nfa_accepts n3 "hello" true;
expect_nfa_accepts n3 "bonjour" true;
expect_nfa_accepts n2 "buongiorno" false;
Printf.printf "*** NFA n4 : n1 . n2 \n";
let n4 = cat_nfa n1 n2 in
expect_nfa_accepts n4 "hello" false;
expect_nfa_accepts n4 "bonjour" false;
expect_nfa_accepts n4 "hellobonjour" true;
expect_nfa_accepts n4 "bonjourhello" false;
Printf.printf "*** NFA n5 : n1* \n";
let n5 = star_nfa n1 (fun _ -> None) in
expect_nfa_accepts n5 "" true;
expect_nfa_accepts n5 "hello" true;
expect_nfa_accepts n5 "hellohello" true;
expect_nfa_accepts n5 "hellobonjour" false;
Printf.printf "*** NFA n6 : n3* \n";
let n6 = star_nfa n3 (fun _ -> None) in
expect_nfa_accepts n6 "" true;
expect_nfa_accepts n6 "hello" true;
expect_nfa_accepts n6 "hellohello" true;
expect_nfa_accepts n6 "hellobonjour" true;
expect_nfa_accepts n6 "hellobonjourhello" true;
expect_nfa_accepts n6 "bonjourbonjourbonjourhello" true;
expect_nfa_accepts n6 "bonjlo" false;
ignore f2
src/tokenize.ml 0 → 100644
View file @ a16795a0
open Batteries
open Lexer_generator
open Report
open Utils
open Options
open Symbols
let tokenize_handwritten file =
Printf.printf "Handwritten lexer\n";
Lexer_generator.tokenize_file file >>= fun tokens ->
OK (List.map (fun tok -> (tok, None)) tokens)
let tokenize_ocamllex file =
Printf.printf "OCamlLex lexer\n";
let ic = open_in file in
let lexbuf = Lexing.from_channel ic in
lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_fname = file };
let rec get_symbols () =
let s = Lexer.token lexbuf in
let ss = (s, Lexing.lexeme_start_p lexbuf) in
if s = SYM_EOF
then [ss]
else ss :: get_symbols ()
in
let l = get_symbols () in
close_in ic;
OK (List.map (fun (tok, pos) -> (tok, Some pos)) l)
let tokenize file =
if !Options.handwritten_lexer
then tokenize_handwritten file
else tokenize_ocamllex file
let pass_tokenize file =
tokenize file >>* (fun msg ->
record_compile_result ~error:(Some msg) "Lexing";
Error msg
) $ fun tokens ->
record_compile_result "Lexing";
dump !show_tokens (fun oc tokens ->
List.iter (fun (tok,_) ->
Format.fprintf oc "%s\n" (string_of_symbol tok)
) tokens) tokens (fun f () -> add_to_report "lexer" "Lexer" (Code (file_contents f)));
OK tokens
src/utils.ml
View file @ a16795a0
open Batteries
open BatPrintf
open BatBuffer
open BatList
......@@ -74,8 +73,6 @@ let write_mem_bytes mem addr bl =
with _ -> Error (Format.sprintf "Problem when writing mem at address %d\n" ofs)
) (OK [])
(* let write_mem_int mem addr v =
* split_bytes !Archi.wordsize v |> rev |> write_mem_bytes mem addr *)
let write_mem_char mem addr c = write_mem_bytes mem addr [c]
......@@ -113,7 +110,7 @@ let read_mem_bytes_as_int mem addr n =
let read_mem_int mem addr =
read_mem_bytes_as_int mem addr !Archi.wordsize
read_mem_bytes_as_int mem addr (Archi.wordsize ())
let read_mem_char mem addr =
read_mem_bytes mem addr 1 >>= fun bl ->
......@@ -133,29 +130,30 @@ module Mem : sig
val write_log : t -> unit -> (int * int) list
end = struct
type t = int array * int list ref * (int * int) list ref
let write_bytes (m,rl,wl) addr bytes =
write_mem_bytes m addr bytes >>= fun w -> wl := !wl @ w; OK ()
let write_char (m,rl,wl) addr c =
write_mem_char m addr c >>= fun w -> wl := !wl @ w; OK ()
let read_bytes (m,rl,wl) addr len =
let write_bytes (m,_,wl) addr bytes =
write_mem_bytes m addr bytes >>= fun w ->
wl := w @ !wl; OK ()
let write_char (m,_,wl) addr c =
write_mem_char m addr c >>= fun w -> wl := w @ !wl; OK ()
let read_bytes (m,rl,_) addr len =
read_mem_bytes m addr len >>= fun (vl,addrl) ->
rl := !rl @ addrl; OK vl
let read_bytes_as_int (m,rl,wl) addr len =
rl := addrl @ !rl ; OK vl
let read_bytes_as_int (m,rl,_) addr len =
read_mem_bytes_as_int m addr len >>= fun (v,addrl) ->
rl := !rl @ addrl; OK v
let read_char (m,rl,wl) addr =
rl := addrl @ !rl; OK v
let read_char (m,rl,_) addr =
read_mem_char m addr >>= fun (v,addrl) ->
rl := !rl @ addrl; OK v
rl := addrl @ !rl; OK v
let init n = Array.init n (fun _ -> 0), ref [], ref []
let read_log (_,rl,_) () = let r = !rl in rl := []; r
let write_log (_,_,wl) () = let w = !wl in wl := []; w
let read_log (_,rl,_) () = let r = !rl in rl := []; List.rev r
let write_log (_,_,wl) () = let w = !wl in wl := []; List.rev w
end
let assoc_opti k l =
let rec aux l n =
match l with
| [] -> None
| (a,v)::l when a = k -> Some (n, v)
| (a,v)::_ when a = k -> Some (n, v)
| _::l -> aux l (n+1)
in
aux l 0
......@@ -170,7 +168,7 @@ let assoc_map_res f l =
OK (acc@[(k,v)])
) (OK []) l
let rec assoc_split fl fr l =
let assoc_split fl fr l =
let rec aux l (accl, accr) =
match l with
| [] -> (accl, accr)
......@@ -246,6 +244,21 @@ let list_map_res f l =
OK (acc@[e])
) (OK []) l
let list_map_resi f l =
List.fold_lefti (fun acc i e ->
acc >>= fun acc ->
f i e >>= fun e ->
OK (acc@[e])
) (OK []) l
let rec list_iter_res f l =
match l with
[] -> OK ()
| a::r ->
f a >>= fun _ ->
list_iter_res f r
let assoc_err ?word:(word="item") k l =
match List.assoc_opt k l with
| Some v -> OK v
......@@ -276,4 +289,59 @@ let string_of_int_list l =
let string_of_int_set s =
string_of_int_list (Set.to_list s)
let string_of_string_set v =
String.concat ", " (Set.to_list v)
let string_of_int_int_set v =
String.concat ", " (List.map (fun (x,y) -> Printf.sprintf "(%d,%d)" x y) (Set.to_list v))
let string_of_int_option v =
match v with
| None -> "undef"
| Some x -> string_of_int x
let dump file (dumpf : _ -> 'a -> unit) (p: 'a) (additional_command: string -> unit -> unit) =
begin match file with
| None -> ()
| Some file ->
let oc, close =
if file = "-"
then (Format.std_formatter, fun _ -> ())
else
let oc = open_out file in
(Format.formatter_of_out_channel oc, fun () -> close_out oc)
in
dumpf oc p; close ();
if file <> "-" then additional_command file ()
end
let process_output_to_list2 = fun command ->
let chan = Unix.open_process_in command in
let res = ref ([] : string list) in
let rec process_otl_aux () =
let e = input_line chan in
res := e::!res;
process_otl_aux() in
try process_otl_aux ()
with End_of_file ->
let stat = Unix.close_process_in chan in (List.rev !res,stat)
let cmd_to_list command =
let (l,_) = process_output_to_list2 command in l
let file_contents file =
match
let ic = open_in file in
let rec aux s () =
try
let line = input_line ic in (* read line from in_channel and discard \n *)
aux (s ^ line ^ "\n") () (* close the input channel *)
with _ -> (* some unexpected exception occurs *)
close_in_noerr ic; (* emergency closing *)
s in
aux "" ()
with
| exception Sys_error _ -> failwith (Printf.sprintf "Could not open file %s\n" file)
| x -> x
src/yaccparser.mly 0 → 100644
View file @ a16795a0
%{
(* open Symbols *)
open Ast
%}
%token SYM_EOF
%token SYM_VOID SYM_CHAR SYM_INT SYM_STRUCT SYM_POINT SYM_BOOL_NOT SYM_BOOL_AND SYM_BOOL_OR
%token SYM_ARROW SYM_BITWISE_OR SYM_BITWISE_AND SYM_BIT_NOT SYM_XOR SYM_LBRACKET SYM_RBRACKET
%token SYM_ALLOC SYM_EXTERN SYM_AMPERSAND
%token<char> SYM_CHARACTER
%token<string> SYM_STRING
%token<string> SYM_INCLUDE
%token<string> SYM_IDENTIFIER
%token<int> SYM_INTEGER
%token SYM_PLUS SYM_MINUS SYM_ASTERISK SYM_DIV SYM_MOD
%token SYM_LPARENTHESIS SYM_RPARENTHESIS SYM_LBRACE SYM_RBRACE
%token SYM_ASSIGN SYM_SEMICOLON SYM_RETURN SYM_IF SYM_WHILE SYM_ELSE SYM_COMMA SYM_PRINT
%token SYM_EQUALITY SYM_NOTEQ SYM_LT SYM_LEQ SYM_GT SYM_GEQ
%left SYM_EQUALITY SYM_NOTEQ
%left SYM_GEQ SYM_LEQ SYM_LT SYM_GT
%left SYM_PLUS SYM_MINUS
%left SYM_ASTERISK SYM_DIV SYM_MOD
%nonassoc UMINUS
%start main
%type <Ast.tree> main
%%
main:
| fundefs SYM_EOF { Node(Tlistglobdef, $1) }
;
fundefs:
| fundef fundefs { $1 :: $2 }
| { [] }
;
fundef:
identifier SYM_LPARENTHESIS lparams SYM_RPARENTHESIS instr {
let fargs = $3 in
let instr = $5 in
Node (Tfundef, [$1; Node (Tfunargs, fargs) ; instr ])
}
;
identifier:
SYM_IDENTIFIER { StringLeaf ($1) }
;
integer : SYM_INTEGER { IntLeaf ($1) };
lparams :
identifier rest_params { Node (Targ, [$1]) :: $2 }
| { [] };
rest_params :
SYM_COMMA identifier rest_params {
Node (Targ, [$2]) :: $3
}
| { [] };
instrs :
| instr instrs { $1 :: $2 }
| { [] };
linstrs :
SYM_LBRACE instrs SYM_RBRACE { Node (Tblock, $2) };
instr :
identifier SYM_ASSIGN expr SYM_SEMICOLON {
Node (Tassign, [Node (Tassignvar,[$1; $3])])
}
| SYM_IF SYM_LPARENTHESIS expr SYM_RPARENTHESIS linstrs ntelse { Node (Tif, [$3; $5; $6]) }
| SYM_WHILE SYM_LPARENTHESIS expr SYM_RPARENTHESIS instr { Node( Twhile, [$3; $5]) }
| SYM_RETURN expr SYM_SEMICOLON { Node(Treturn, [$2]) }
| SYM_PRINT expr SYM_SEMICOLON { Node(Tprint, [$2]) }
| linstrs { $1 };
ntelse :
SYM_ELSE linstrs { $2 }
| { Node(Tblock, []) };
expr :
| expr SYM_EQUALITY expr { Node (Tceq, [$1; $3]) }
| expr SYM_NOTEQ expr { Node (Tne, [$1; $3]) }
| expr SYM_PLUS expr { Node (Tadd, [$1; $3]) }
| expr SYM_MINUS expr { Node (Tsub, [$1; $3]) }
| expr SYM_ASTERISK expr { Node (Tmul, [$1; $3]) }
| expr SYM_DIV expr { Node (Tdiv, [$1; $3]) }
| expr SYM_MOD expr { Node (Tmod, [$1; $3]) }
| expr SYM_LT expr { Node (Tclt, [$1; $3]) }
| expr SYM_GT expr { Node (Tcgt, [$1; $3]) }
| expr SYM_LEQ expr { Node (Tcle, [$1; $3]) }
| expr SYM_GEQ expr { Node (Tcge, [$1; $3]) }
| SYM_MINUS expr %prec UMINUS { Node (Tneg, [$2])}
| integer { Node(Tint, [$1])}
| identifier { $1 }
| SYM_LPARENTHESIS expr SYM_RPARENTHESIS { $2 }
;
tests/.gitignore 0 → 100644
View file @ a16795a0
**/*.ast
**/*.cfg
**/*.cfg0
**/*.cfg1
**/*.cfg2
**/*.cfg3
**/*.e.dump
**/*.e.html
**/*.exe
**/*.json
**/*.lex
**/*.linear
**/*.linear1
**/*.ltl
**/*.rig
**/*.rtl
**/*.s
**/*.svg
results.html
__pycache__
\ No newline at end of file
tests/Makefile
View file @ a16795a0
# if make is launched with a DIR variable, pass it as the -f option to test.py
# 'make DIR=basic/mul*.e' launches all the files starting with mul in the basic directory
# otherwise, use basic/*.e as a default
OPTS := $(if $(DIR),-f $(DIR),-f basic/*.e)
FILES := $(if $(DIR),$(DIR),basic/*.e)
OPTS := $(if $(OPTS), $(OPTS),)
.PHONY: all
all: ../main.native
./test.py $(OPTS)
all: ../ecomp
./test.py -f $(FILES) $(OPTS)
expect: ../ecomp
OCAMLRUNPARAM=b ./test.py --make-expect -f $(FILES) $(OPTS) --args 1 2 3
OCAMLRUNPARAM=b ./test.py --make-expect -f $(FILES) $(OPTS) --args 14 12 3 8 12
for f in $(FILES); do ../ecomp -f $$f -show-tokens $$f.expect_lexer; done
clean:
find . -name *.ltl -or -name *.cfg -or -name *.exe -or -name *.s -or -name \
*.rtl -or -name *.ast -or -name *.cfg0 -or -name *.cfg1 -or -name *.cfg2 -or \
-name *.riscv -or -name *.dump -or -name *.linear1 -or -name *.linear -or \
-name *.html -or -name *.svg -or -name *.html -or -name *.lex | xargs -I{} rm \
{}
find . -name '*.rig' -or -name '*.ltl' -or -name '*.cfg' -or -name '*.exe' -or -name '*.s' -or -name '*.rtl' -or -name '*.ast' -or -name '*.cfg0' -or -name '*.cfg1' -or -name '*.cfg2' -or -name '*.cfg3' -or -name '*.riscv' -or -name '*.dump' -or -name '*.linear1' -or -name '*.linear' -or -name '*.html' -or -name '*.svg' -or -name '*.html' -or -name '*.lex' -or -name "*.json" | xargs -I{} rm {}
rm -rf __pycache__
tests/array/array.e
View file @ a16795a0
int main(int argc,char* argv[]){
int main(){
int t[10];
t[0] = 5;
t[1] = 3 + t[0];
......
tests/array/array.e.expect_14_12_3_8_12 0 → 100644
View file @ a16795a0
{"output": "", "error": null, "retval": 8}
\ No newline at end of file
tests/array/array.e.expect_1_2_3 0 → 100644
View file @ a16795a0
{"output": "", "error": null, "retval": 8}
\ No newline at end of file
tests/array/array.e.expect_lexer 0 → 100644
View file @ a16795a0
SYM_INT
SYM_IDENTIFIER(main)
SYM_LPARENTHESIS
SYM_RPARENTHESIS
SYM_LBRACE
SYM_INT
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_INTEGER(10)
SYM_RBRACKET
SYM_SEMICOLON
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_INTEGER(0)
SYM_RBRACKET
SYM_ASSIGN
SYM_INTEGER(5)
SYM_SEMICOLON
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_INTEGER(1)
SYM_RBRACKET
SYM_ASSIGN
SYM_INTEGER(3)
SYM_PLUS
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_INTEGER(0)
SYM_RBRACKET
SYM_SEMICOLON
SYM_RETURN
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_INTEGER(1)
SYM_RBRACKET
SYM_SEMICOLON
SYM_RBRACE
SYM_EOF
tests/array/array2.e
View file @ a16795a0
int main(int argc,char* argv[]){
int main(){
int t[10];
int i = 0;
while(i < 10){
......
tests/array/array2.e.expect_14_12_3_8_12 0 → 100644
View file @ a16795a0
{"output": "", "error": null, "retval": 45}
\ No newline at end of file
tests/array/array2.e.expect_1_2_3 0 → 100644
View file @ a16795a0
{"output": "", "error": null, "retval": 45}
\ No newline at end of file
tests/array/array2.e.expect_lexer 0 → 100644
View file @ a16795a0
SYM_INT
SYM_IDENTIFIER(main)
SYM_LPARENTHESIS
SYM_RPARENTHESIS
SYM_LBRACE
SYM_INT
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_INTEGER(10)
SYM_RBRACKET
SYM_SEMICOLON
SYM_INT
SYM_IDENTIFIER(i)
SYM_ASSIGN
SYM_INTEGER(0)
SYM_SEMICOLON
SYM_WHILE
SYM_LPARENTHESIS
SYM_IDENTIFIER(i)
SYM_LT
SYM_INTEGER(10)
SYM_RPARENTHESIS
SYM_LBRACE
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_IDENTIFIER(i)
SYM_RBRACKET
SYM_ASSIGN
SYM_IDENTIFIER(i)
SYM_SEMICOLON
SYM_IDENTIFIER(i)
SYM_ASSIGN
SYM_IDENTIFIER(i)
SYM_PLUS
SYM_INTEGER(1)
SYM_SEMICOLON
SYM_RBRACE
SYM_INT
SYM_IDENTIFIER(sum)
SYM_ASSIGN
SYM_INTEGER(0)
SYM_SEMICOLON
SYM_IDENTIFIER(i)
SYM_ASSIGN
SYM_INTEGER(0)
SYM_SEMICOLON
SYM_WHILE
SYM_LPARENTHESIS
SYM_IDENTIFIER(i)
SYM_LT
SYM_INTEGER(10)
SYM_RPARENTHESIS
SYM_LBRACE
SYM_IDENTIFIER(sum)
SYM_ASSIGN
SYM_IDENTIFIER(sum)
SYM_PLUS
SYM_IDENTIFIER(t)
SYM_LBRACKET
SYM_IDENTIFIER(i)
SYM_RBRACKET
SYM_SEMICOLON
SYM_IDENTIFIER(i)
SYM_ASSIGN
SYM_IDENTIFIER(i)
SYM_PLUS
SYM_INTEGER(1)
SYM_SEMICOLON
SYM_RBRACE
SYM_RETURN
SYM_IDENTIFIER(sum)
SYM_SEMICOLON
SYM_RBRACE
SYM_EOF