From 6df998ceb1b07d0dcc84a9e6edcf41ee64e2458f Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Mon, 3 Mar 2025 12:21:10 +0100
Subject: [PATCH 01/11] lexer and parser
---
ecomp | 1 +
expr_grammar_action.g | 65 ++++++++++++-
src/e_regexp.ml | 58 ++++++------
src/lexer_generator.ml | 156 ++++++++++++++++++++++---------
src/test_lexer.ml | 2 +-
tests/basic/just_a_variable_37.e | 4 +-
6 files changed, 205 insertions(+), 81 deletions(-)
create mode 120000 ecomp
diff --git a/ecomp b/ecomp
new file mode 120000
index 0000000..b09fe7b
--- /dev/null
+++ b/ecomp
@@ -0,0 +1 @@
+src/_build/default/main.exe
\ No newline at end of file
diff --git a/expr_grammar_action.g b/expr_grammar_action.g
index 9ab7ecd..d7734d1 100644
--- a/expr_grammar_action.g
+++ b/expr_grammar_action.g
@@ -20,13 +20,68 @@ axiom S
open Batteries
open Utils
+
(* TODO *)
- let resolve_associativity term other =
+ let rec resolve_associativity (term : tree) (other : (tag * tree) list) =
(* TODO *)
- term
-
-
+ match List.rev other with
+ | [] -> term
+ | (high_tag, right_side)::rest -> Node(high_tag, [resolve_associativity term (List.rev rest); right_side])
}
rules
-S -> FUNDEFS SYM_EOF { Node (Tlistglobdef, []) }
+S -> FUNDEFS SYM_EOF { Node(Tlistglobdef, $1) }
+FUNDEFS -> FUNDEF FUNDEFS { Node(Tfundef, $1)::$2 }
+FUNDEFS -> { [] }
+FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE { [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$6])] }
+
+LPARAMS -> IDENTIFIER REST_PARAMS { $1::$2 }
+LPARAMS -> { [] }
+REST_PARAMS -> SYM_COMMA LPARAMS { $2 }
+REST_PARAMS -> { [] }
+
+LINSTRS -> INSTR INSTRS { Node(Tblock, $1::$2) }
+LINSTRS -> { NullLeaf }
+INSTRS -> INSTR INSTRS { $1::$2 }
+INSTRS -> { [] }
+
+INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE ELSE { Node(Tif, [$3; $6; $8]) }
+INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE { Node(Twhile, [$3; $6]) }
+INSTR -> SYM_RETURN EXPR SYM_SEMICOLON { Node(Treturn, [$2]) }
+INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON { Node(Tprint, [$3]) }
+INSTR -> IDENTIFIER SYM_ASSIGN EXPR SYM_SEMICOLON { Node(Tassign, [$1; $3]) }
+
+ELSE -> SYM_ELSE SYM_LBRACE LINSTRS SYM_RBRACE { $3 }
+ELSE -> { NullLeaf }
+
+EXPR -> EQ_EXPR EQ_EXPRS { resolve_associativity $1 $2 }
+EQ_EXPR -> CMP_EXPR CMP_EXPRS { resolve_associativity $1 $2 }
+CMP_EXPR -> ADD_EXPR ADD_EXPRS { resolve_associativity $1 $2 }
+ADD_EXPR -> MUL_EXPR MUL_EXPRS { resolve_associativity $1 $2 }
+MUL_EXPR -> FACTOR { $1 }
+
+EQ_EXPRS -> SYM_EQUALITY EQ_EXPR EQ_EXPRS { (Tceq, $2)::$3 }
+EQ_EXPRS -> SYM_NOTEQ EQ_EXPR EQ_EXPRS { (Tne, $2)::$3 }
+EQ_EXPRS -> { [] }
+
+CMP_EXPRS -> SYM_LT CMP_EXPR CMP_EXPRS { (Tclt, $2)::$3 }
+CMP_EXPRS -> SYM_LEQ CMP_EXPR CMP_EXPRS { (Tcle, $2)::$3 }
+CMP_EXPRS -> SYM_GT CMP_EXPR CMP_EXPRS { (Tcgt, $2)::$3 }
+CMP_EXPRS -> SYM_GEQ CMP_EXPR CMP_EXPRS { (Tcge, $2)::$3 }
+CMP_EXPRS -> { [] }
+
+ADD_EXPRS -> SYM_PLUS ADD_EXPR ADD_EXPRS { (Tadd, $2)::$3 }
+ADD_EXPRS -> SYM_MINUS ADD_EXPR ADD_EXPRS { (Tsub, $2)::$3 }
+ADD_EXPRS -> { [] }
+
+MUL_EXPRS -> SYM_ASTERISK MUL_EXPR MUL_EXPRS { (Tmul, $2)::$3 }
+MUL_EXPRS -> SYM_DIV MUL_EXPR MUL_EXPRS { (Tdiv, $2)::$3 }
+MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS { (Tmod, $2)::$3 }
+MUL_EXPRS -> { [] }
+
+FACTOR -> INTEGER { $1 }
+FACTOR -> IDENTIFIER { $1 }
+FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS { $2 }
+
+IDENTIFIER -> SYM_IDENTIFIER {StringLeaf $1}
+INTEGER -> SYM_INTEGER {IntLeaf $1}
diff --git a/src/e_regexp.ml b/src/e_regexp.ml
index bbc5b20..a87413d 100644
--- a/src/e_regexp.ml
+++ b/src/e_regexp.ml
@@ -69,35 +69,35 @@ let list_regexp : (regexp * (string -> token option)) list =
(keyword_regexp "while", fun _ -> Some (SYM_WHILE));
(keyword_regexp "int", fun _ -> Some (SYM_INT));
(* begin TODO *)
- (Eps, fun _ -> Some (SYM_VOID));
- (Eps, fun _ -> Some (SYM_CHAR));
- (Eps, fun _ -> Some (SYM_IF));
- (Eps, fun _ -> Some (SYM_ELSE));
- (Eps, fun _ -> Some (SYM_RETURN));
- (Eps, fun _ -> Some (SYM_PRINT));
- (Eps, fun _ -> Some (SYM_STRUCT));
- (Eps, fun _ -> Some (SYM_POINT));
- (Eps, fun _ -> Some (SYM_PLUS));
- (Eps, fun _ -> Some (SYM_MINUS));
- (Eps, fun _ -> Some (SYM_ASTERISK));
- (Eps, fun _ -> Some (SYM_DIV));
- (Eps, fun _ -> Some (SYM_MOD));
- (Eps, fun _ -> Some (SYM_LBRACE));
- (Eps, fun _ -> Some (SYM_RBRACE));
- (Eps, fun _ -> Some (SYM_LBRACKET));
- (Eps, fun _ -> Some (SYM_RBRACKET));
- (Eps, fun _ -> Some (SYM_LPARENTHESIS));
- (Eps, fun _ -> Some (SYM_RPARENTHESIS));
- (Eps, fun _ -> Some (SYM_SEMICOLON));
- (Eps, fun _ -> Some (SYM_COMMA));
- (Eps, fun _ -> Some (SYM_ASSIGN));
- (Eps, fun _ -> Some (SYM_EQUALITY));
- (Eps, fun _ -> Some (SYM_NOTEQ));
- (Eps, fun _ -> Some (SYM_LT));
- (Eps, fun _ -> Some (SYM_GT));
- (Eps, fun _ -> Some (SYM_LEQ));
- (Eps, fun _ -> Some (SYM_GEQ));
- (Eps, fun s -> Some (SYM_IDENTIFIER s));
+ (keyword_regexp "void", fun _ -> Some (SYM_VOID));
+ (keyword_regexp "void", fun _ -> Some (SYM_CHAR));
+ (keyword_regexp "if", fun _ -> Some (SYM_IF));
+ (keyword_regexp "else", fun _ -> Some (SYM_ELSE));
+ (keyword_regexp "return", fun _ -> Some (SYM_RETURN));
+ (keyword_regexp "print", fun _ -> Some (SYM_PRINT));
+ (keyword_regexp "struct", fun _ -> Some (SYM_STRUCT));
+ (char_regexp '.', fun _ -> Some (SYM_POINT));
+ (char_regexp '+', fun _ -> Some (SYM_PLUS));
+ (char_regexp '-', fun _ -> Some (SYM_MINUS));
+ (char_regexp '*', fun _ -> Some (SYM_ASTERISK));
+ (char_regexp '/', fun _ -> Some (SYM_DIV));
+ (char_regexp '%', fun _ -> Some (SYM_MOD));
+ (char_regexp '{', fun _ -> Some (SYM_LBRACE));
+ (char_regexp '}', fun _ -> Some (SYM_RBRACE));
+ (char_regexp '[', fun _ -> Some (SYM_LBRACKET));
+ (char_regexp ']', fun _ -> Some (SYM_RBRACKET));
+ (char_regexp '(', fun _ -> Some (SYM_LPARENTHESIS));
+ (char_regexp ')', fun _ -> Some (SYM_RPARENTHESIS));
+ (char_regexp ';', fun _ -> Some (SYM_SEMICOLON));
+ (char_regexp ',', fun _ -> Some (SYM_COMMA));
+ (char_regexp '=', fun _ -> Some (SYM_ASSIGN));
+ (Cat(char_regexp '=', char_regexp '='), fun _ -> Some (SYM_EQUALITY));
+ (Cat(char_regexp '!', char_regexp '='), fun _ -> Some (SYM_NOTEQ));
+ (char_regexp '<', fun _ -> Some (SYM_LT));
+ (char_regexp '>', fun _ -> Some (SYM_GT));
+ (Cat(char_regexp '<', char_regexp '='), fun _ -> Some (SYM_LEQ));
+ (Cat(char_regexp '>', char_regexp '='), fun _ -> Some (SYM_GEQ));
+ (Cat(Alt(letter_regexp, char_regexp '_'), Star identifier_material), fun s -> Some (SYM_IDENTIFIER s));
(* end TODO *)
(Cat(keyword_regexp "//",
Cat(Star (char_range (List.filter (fun c -> c <> '\n') alphabet)),
diff --git a/src/lexer_generator.ml b/src/lexer_generator.ml
index 06192ef..e75d1ee 100644
--- a/src/lexer_generator.ml
+++ b/src/lexer_generator.ml
@@ -45,41 +45,70 @@ let empty_nfa =
(* Concaténation de NFAs. *)
let cat_nfa n1 n2 =
- (* TODO *)
- empty_nfa
+ (* TODO *)
+ {
+ nfa_states = n1.nfa_states @ n2.nfa_states;
+ nfa_initial = n1.nfa_initial;
+ nfa_final = n2.nfa_final;
+ nfa_step = fun q ->
+ if List.mem q (List.map (fun x -> fst(x)) n1.nfa_final)
+ then n1.nfa_step(q)@List.map (fun x -> (None, x)) n2.nfa_initial
+ else n1.nfa_step(q)@n2.nfa_step(q)
+ }
(* Alternatives de NFAs *)
let alt_nfa n1 n2 =
- (* TODO *)
- empty_nfa
+ (* TODO *)
+ {
+ nfa_states = n1.nfa_states @ n2.nfa_states;
+ nfa_initial = n1.nfa_initial @ n2.nfa_initial;
+ nfa_final = n1.nfa_final @ n2.nfa_final;
+ nfa_step = fun q -> n1.nfa_step(q) @ n2.nfa_step(q)
+ }
(* Répétition de NFAs *)
(* t est de type [string -> token option] *)
let star_nfa n t =
- (* TODO *)
- empty_nfa
-
+ (* TODO *)
+ {
+ nfa_states = n.nfa_states;
+ nfa_initial = n.nfa_initial;
+ nfa_final = (List.map (fun x -> fst x, t) n.nfa_final) @ (List.map (fun x -> x, t) n.nfa_initial);
+ nfa_step = fun q ->
+ if List.mem q (List.map (fun x -> fst x) n.nfa_final)
+ then n.nfa_step q @ List.map (fun x -> None, x) n.nfa_initial
+ else n.nfa_step q
+ }
(* [nfa_of_regexp r freshstate t] construit un NFA qui reconnaît le même langage
que l'expression régulière [r].
- [freshstate] correspond à un entier pour lequel il n'y a pas encore d'état dans
+ [freshstate] correspond à un entier pour leq uel il n'y a pas encore d'état dans
le nfa. Il suffit d'incrémenter [freshstate] pour obtenir de nouveaux états non utilisés.
[t] est une fonction du type [string -> token option] utile pour les états finaux.
*)
let rec nfa_of_regexp r freshstate t =
match r with
| Eps -> { nfa_states = [freshstate];
- nfa_initial = [freshstate];
- nfa_final = [(freshstate,t)];
- nfa_step = fun q -> []}, freshstate + 1
+ nfa_initial = [freshstate];
+ nfa_final = [(freshstate,t)];
+ nfa_step = fun q -> []}, freshstate + 1
| Charset c -> { nfa_states = [freshstate; freshstate + 1];
nfa_initial = [freshstate];
nfa_final = [freshstate + 1, t];
nfa_step = fun q -> if q = freshstate then [(Some c, freshstate + 1)] else []
}, freshstate + 2
- (* TODO *)
- | _ -> empty_nfa, freshstate
-
+ (* TODO *)
+ | Cat(r1, r2) ->
+ let n1, intermediate_freshstate = nfa_of_regexp r1 freshstate t
+ in let n2, final_freshstate = nfa_of_regexp r2 intermediate_freshstate t
+ in (cat_nfa n1 n2, final_freshstate);
+ | Alt(r1, r2) ->
+ let n1, intermediate_freshstate = nfa_of_regexp r1 freshstate t
+ in let n2, final_freshstate = nfa_of_regexp r2 intermediate_freshstate t
+ in (alt_nfa n1 n2, final_freshstate);
+ | Star r ->
+ let n, final_freshstate = nfa_of_regexp r freshstate t
+ in star_nfa n t, final_freshstate;
(* Deterministic Finite Automaton (DFA) *)
(* Les états d'un DFA [dfa_state] sont des ensembles d'entiers.
@@ -119,21 +148,26 @@ let epsilon_closure (n: nfa) (s: nfa_state) : nfa_state set =
(* La fonction [traversal visited s] effectue un parcours de l'automate en
partant de l'état [s], et en suivant uniquement les epsilon-transitions. *)
let rec traversal (visited: nfa_state set) (s: nfa_state) : nfa_state set =
- (* TODO *)
- visited
- in
- traversal Set.empty s
+ (* TODO *)
+ let direct_epsilon_closure = List.map (fun x -> snd x) (List.filter (fun x -> fst x == None) (n.nfa_step s))
+ in let not_visited_direct_epsilon_closure = List.filter (fun x -> not(Set.mem x visited)) direct_epsilon_closure
+ in let visited_with_s = Set.add s visited
+ in if Set.mem s visited
+ then visited
+ else List.fold_left (fun acc x -> Set.union (traversal visited_with_s x) acc) visited_with_s not_visited_direct_epsilon_closure
+ in traversal Set.empty s
(* [epsilon_closure_set n ls] calcule l'union des epsilon-fermeture de chacun
des états du NFA [n] dans l'ensemble [ls]. *)
let epsilon_closure_set (n: nfa) (ls: nfa_state set) : nfa_state set =
- (* TODO *)
- ls
+ (* TODO *)
+ let set_of_epsilon_closures = (Set.map (fun x -> epsilon_closure n x) ls)
+ in Set.fold (fun acc x -> Set.union x acc) set_of_epsilon_closures Set.empty
(* [dfa_initial_state n] calcule l'état initial de l'automate déterminisé. *)
let dfa_initial_state (n: nfa) : dfa_state =
- (* TODO *)
- Set.empty
+ (* TODO *)
+ epsilon_closure_set n (Set.of_list n.nfa_initial)
(* Construction de la table de transitions de l'automate DFA. *)
@@ -180,19 +214,17 @@ let assoc_merge_vals (l : ('a * 'b) list) : ('a * 'b set) list =
| Some vl -> (k, Set.add v vl)::List.remove_assoc k acc
) [] l
-let rec build_dfa_table (table: (dfa_state, (char * dfa_state) list) Hashtbl.t)
- (n: nfa)
- (ds: dfa_state) : unit =
+let rec build_dfa_table (table: (dfa_state, (char * dfa_state) list) Hashtbl.t) (n: nfa) (ds: dfa_state) : unit =
match Hashtbl.find_option table ds with
| Some _ -> ()
| None ->
(* [transitions] contient les transitions du DFA construites
- * à partir des transitions du NFA comme décrit auparavant *)
+ * à partir des transitions du NFA comme décrit auparavant *)
let transitions : (char * dfa_state) list =
- (* TODO *)
- []
- in
- Hashtbl.replace table ds transitions;
+ (* TODO *)
+ let t = Set.fold (fun x acc -> acc @ n.nfa_step x) ds []
+ in List.map (fun x -> fst x, epsilon_closure_set n (snd x)) (assoc_merge_vals (assoc_distribute_key (assoc_throw_none t)))
+ in Hashtbl.replace table ds transitions;
List.iter (build_dfa_table table n) (List.map snd transitions)
(* Calcul des états finaux de l'automate DFA *)
@@ -223,17 +255,31 @@ let priority t =
| _ -> 0
(* [min_priority l] renvoie le token de [l] qui a la plus petite priorité, ou
- [None] si la liste [l] est vide. *)
+ [None] si la liste [l] est vide. *)
let min_priority (l: token list) : token option =
- (* TODO *)
- None
+ (* TODO *)
+ match l with
+ | [] -> None
+ | _ -> Some(List.fold_left (fun x acc -> if priority x < priority acc then x else acc) SYM_EOF l)
(* [dfa_final_states n dfa_states] renvoie la liste des états finaux du DFA,
accompagnés du token qu'ils reconnaissent. *)
let dfa_final_states (n: nfa) (dfa_states: dfa_state list) :
(dfa_state * (string -> token option)) list =
- (* TODO *)
- []
+ (* TODO *)
+ let dfa_final_states_list : nfa_state set list=
+ let is_final q = List.mem q (List.map (fun x -> fst(x)) n.nfa_final)
+ in List.filter (fun ds -> Set.exists is_final ds) dfa_states
+ in let function_of_nfa_state ns =
+ assoc_opt ns n.nfa_final
+ in let functions_of_dfa_state (ds : dfa_state) =
+ (List.filter_map function_of_nfa_state (Set.to_list ds)) (* use List.filter_map instead of Set.filter_map to avoid the error*)
+ in let constructed_function ds =
+ fun s ->
+ let images_of_s : token list
+ = List.filter_map (fun (t) -> t s) (functions_of_dfa_state ds)
+ in min_priority images_of_s
+ in List.map (fun (ds : dfa_state ) -> ds, constructed_function ds) dfa_final_states_list
(* Construction de la relation de transition du DFA. *)
@@ -241,8 +287,13 @@ let dfa_final_states (n: nfa) (dfa_states: dfa_state list) :
est la table générée par [build_dfa_table], définie ci-dessus. *)
let make_dfa_step (table: (dfa_state, (char * dfa_state) list) Hashtbl.t) =
fun (q: dfa_state) (a: char) ->
- (* TODO *)
- None
+ (* TODO *)
+ match Hashtbl.find_option table q with
+ | None -> None
+ | Some l ->
+ match List.filter (fun x -> fst x = a) l with
+ | [] -> None
+ | (c, ds)::rest -> Some ds
(* Finalement, on assemble tous ces morceaux pour construire l'automate. La
fonction [dfa_of_nfa n] vous est grâcieusement offerte. *)
@@ -306,13 +357,29 @@ type lexer_result =
*)
let tokenize_one (d : dfa) (w: char list) : lexer_result * char list =
- let rec recognize (q: dfa_state) (w: char list)
- (current_token: char list) (last_accepted: lexer_result * char list)
- : lexer_result * char list =
- (* TODO *)
- last_accepted
- in
- recognize d.dfa_initial w [] (LRerror, w)
+ let rec recognize (q: dfa_state) (w: char list) (current_word: char list) (last_accepted: lexer_result * char list) : lexer_result * char list =
+ (* TODO *)
+ let token_function ds =
+ assoc_opt ds d.dfa_final
+ in let new_accepted =
+ match token_function q with
+ | None -> last_accepted
+ | Some t ->
+ match (t (string_of_char_list current_word)) with
+ | None -> LRskip, w
+ | Some tok -> LRtoken tok, w
+ in if List.is_empty w
+ then new_accepted
+ else let next_state_option = d.dfa_step q (hd w)
+ in match next_state_option with
+ | None -> new_accepted
+ | Some next_state -> recognize next_state (tl w) (current_word@[hd w]) new_accepted
+
+ in recognize d.dfa_initial w [] (LRerror, w)
+
+(*
+ recognize 3 "iler" "wh" (SYM_(w), "hile") -> (SYM_WHILE, "r")
+*)
(* La fonction [tokenize_all d w] répète l'application de [tokenize_one] tant qu'on
n'est pas arrivé à la fin du fichier (token [SYM_EOF]). Encore une fois,
@@ -326,6 +393,7 @@ let rec tokenize_all (d: dfa) (w: char list) : (token list * char list) =
if token = SYM_EOF
then ([], w)
else tokenize_all d w in
+ (*print_endline (string_of_symbol token);*)
(token :: tokens, w)
diff --git a/src/test_lexer.ml b/src/test_lexer.ml
index 72ffda4..40c9f8e 100644
--- a/src/test_lexer.ml
+++ b/src/test_lexer.ml
@@ -42,7 +42,7 @@ let () =
] in
(* Décommentez la ligne suivante pour tester sur la vraie liste d'expressions
régulières. *)
- (* let regexp_list = list_regexp in *)
+ (*let regexp_list = list_regexp in*)
List.iteri
(fun i (rg, _) -> Printf.printf "%d: %s\n" i (string_of_regexp rg))
regexp_list;
diff --git a/tests/basic/just_a_variable_37.e b/tests/basic/just_a_variable_37.e
index 51add73..3551b56 100644
--- a/tests/basic/just_a_variable_37.e
+++ b/tests/basic/just_a_variable_37.e
@@ -1,4 +1,4 @@
main(){
- just_a_variable = 37;
- return just_a_variable;
+ just_a_variable = 37;
+ return just_a_variable;
}
--
GitLab
From b0d4b068aacd1924f234083c97a48a1049fc3929 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Mon, 3 Mar 2025 14:58:18 +0100
Subject: [PATCH 02/11] grammar correction : an instruction can be a block
---
expr_grammar_action.g | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/expr_grammar_action.g b/expr_grammar_action.g
index d7734d1..d1d0e24 100644
--- a/expr_grammar_action.g
+++ b/expr_grammar_action.g
@@ -33,7 +33,7 @@ rules
S -> FUNDEFS SYM_EOF { Node(Tlistglobdef, $1) }
FUNDEFS -> FUNDEF FUNDEFS { Node(Tfundef, $1)::$2 }
FUNDEFS -> { [] }
-FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE { [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$6])] }
+FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$5])] }
LPARAMS -> IDENTIFIER REST_PARAMS { $1::$2 }
LPARAMS -> { [] }
@@ -46,10 +46,11 @@ INSTRS -> INSTR INSTRS { $1::$2 }
INSTRS -> { [] }
INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE ELSE { Node(Tif, [$3; $6; $8]) }
-INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE { Node(Twhile, [$3; $6]) }
+INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS INSTR { Node(Twhile, [$3; $5]) }
INSTR -> SYM_RETURN EXPR SYM_SEMICOLON { Node(Treturn, [$2]) }
INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON { Node(Tprint, [$3]) }
INSTR -> IDENTIFIER SYM_ASSIGN EXPR SYM_SEMICOLON { Node(Tassign, [$1; $3]) }
+INSTR -> SYM_LBRACE LINSTRS SYM_RBRACE { $2 }
ELSE -> SYM_ELSE SYM_LBRACE LINSTRS SYM_RBRACE { $3 }
ELSE -> { NullLeaf }
--
GitLab
From ece99692f775b3cbf9ba5cc2e957d6598d87ecaa Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Mon, 3 Mar 2025 17:15:10 +0100
Subject: [PATCH 03/11] grammar correction : use of Targ tag
---
expr_grammar_action.g | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/expr_grammar_action.g b/expr_grammar_action.g
index d1d0e24..9d5d588 100644
--- a/expr_grammar_action.g
+++ b/expr_grammar_action.g
@@ -31,11 +31,11 @@ axiom S
rules
S -> FUNDEFS SYM_EOF { Node(Tlistglobdef, $1) }
-FUNDEFS -> FUNDEF FUNDEFS { Node(Tfundef, $1)::$2 }
+FUNDEFS -> FUNDEF FUNDEFS { $1::$2 }
FUNDEFS -> { [] }
-FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$5])] }
+FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { Node(Tfundef, [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$5])]) }
-LPARAMS -> IDENTIFIER REST_PARAMS { $1::$2 }
+LPARAMS -> IDENTIFIER REST_PARAMS { Node(Targ, [$1])::$2 }
LPARAMS -> { [] }
REST_PARAMS -> SYM_COMMA LPARAMS { $2 }
REST_PARAMS -> { [] }
--
GitLab
From f54acb726567ce0fb04c0d092a66da41cd726e66 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Thu, 6 Mar 2025 00:35:06 +0100
Subject: [PATCH 04/11] e-run
---
src/elang.ml | 2 +-
src/elang_gen.ml | 56 ++++++++++++++++++++++++++++++---
src/elang_run.ml | 80 +++++++++++++++++++++++++++++++++++++++++++++---
3 files changed, 128 insertions(+), 10 deletions(-)
diff --git a/src/elang.ml b/src/elang.ml
index 72b8e18..3e6fcf0 100644
--- a/src/elang.ml
+++ b/src/elang.ml
@@ -6,7 +6,7 @@ type unop = Eneg
type expr =
Ebinop of binop * expr * expr
- | Eunop of unop * expr
+ | Eunop of unop * expr (*unused*)
| Eint of int
| Evar of string
diff --git a/src/elang_gen.ml b/src/elang_gen.ml
index be904b1..86761b7 100644
--- a/src/elang_gen.ml
+++ b/src/elang_gen.ml
@@ -44,10 +44,18 @@ let binop_of_tag =
let rec make_eexpr_of_ast (a: tree) : expr res =
let res =
match a with
+ (* TODO *)
+ | IntLeaf i -> OK (Eint i)
+ | StringLeaf s -> OK (Evar s)
| Node(t, [e1; e2]) when tag_is_binop t ->
- Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
- (string_of_ast a))
- | _ -> Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
+ (let res1 = make_eexpr_of_ast e1
+ in let res2 = make_eexpr_of_ast e2
+ in match res1, res2 with
+ | Error msg, _ -> Error msg
+ | _, Error msg -> Error msg
+ | OK expr1, OK expr2 -> OK (Ebinop (binop_of_tag t, expr1, expr2)))
+ | _ ->
+ Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
(string_of_ast a))
in
match res with
@@ -59,6 +67,43 @@ let rec make_einstr_of_ast (a: tree) : instr res =
let res =
match a with
(* TODO *)
+ | Node(Tassign, [StringLeaf s; e]) ->
+ (let res_of_e = make_eexpr_of_ast e
+ in match res_of_e with
+ | OK exp -> OK (Iassign (s, exp))
+ | Error msg -> Error msg)
+ | Node(Tif, [e; i1; i2]) ->
+ (let res_of_e = make_eexpr_of_ast e
+ in let res_of_i1 = make_einstr_of_ast i1
+ in let res_of_i2 = make_einstr_of_ast i2
+ in match res_of_e, res_of_i1, res_of_i2 with
+ | Error msg, _, _ -> Error msg
+ | _, Error msg, _ -> Error msg
+ | _, _, Error msg -> Error msg
+ | OK exp, OK inst1, OK inst2 -> OK (Iif (exp, inst1, inst2)))
+ | Node(Twhile, [e; i]) ->
+ (let res_of_e = make_eexpr_of_ast e
+ in let res_of_i = make_einstr_of_ast i
+ in match res_of_e, res_of_i with
+ | Error msg, _ -> Error msg
+ | _, Error msg -> Error msg
+ | OK exp, OK inst-> OK (Iwhile (exp, inst)))
+ | Node(Tblock, i_list) ->
+ (let res_of_i_list = list_map_res make_einstr_of_ast i_list
+ in match res_of_i_list with
+ | Error msg -> Error msg
+ | OK instr_list -> OK (Iblock instr_list))
+ | Node(Treturn, [e]) ->
+ (let res_of_e = make_eexpr_of_ast e
+ in match res_of_e with
+ | OK exp -> OK (Ireturn exp)
+ | Error msg -> Error msg)
+ | Node(Tprint, [e]) ->
+ (let res_of_e = make_eexpr_of_ast e
+ in match res_of_e with
+ | OK exp -> OK (Iprint exp)
+ | Error msg -> Error msg)
+ | NullLeaf -> OK (Iblock [])
| _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
(string_of_ast a))
in
@@ -76,10 +121,11 @@ let make_ident (a: tree) : string res =
let make_fundef_of_ast (a: tree) : (string * efun) res =
match a with
- | Node (Tfundef, [StringLeaf fname; Node (Tfunargs, fargs); fbody]) ->
+ | Node (Tfundef, [Node(Tfunname, [StringLeaf fname]); Node (Tfunargs, fargs); Node(Tfunbody, [fbody])]) ->
list_map_res make_ident fargs >>= fun fargs ->
(* TODO *)
- Error "make_fundef_of_ast: Not implemented, yet."
+ make_einstr_of_ast fbody >>= fun fbody ->
+ OK (fname, {funargs = fargs; funbody = fbody})
| _ ->
Error (Printf.sprintf "make_fundef_of_ast: Expected a Tfundef, got %s."
(string_of_ast a))
diff --git a/src/elang_run.ml b/src/elang_run.ml
index 494b2c6..13afe7c 100644
--- a/src/elang_run.ml
+++ b/src/elang_run.ml
@@ -9,17 +9,46 @@ let binop_bool_to_int f x y = if f x y then 1 else 0
et [y]. *)
let eval_binop (b: binop) : int -> int -> int =
match b with
- | _ -> fun x y -> 0
+ | Eadd -> fun x y -> x + y
+ | Emul -> fun x y -> x * y
+ | Emod -> fun x y -> x mod y
+ | Exor -> fun x y -> x lxor y
+ | Ediv -> fun x y -> x / y
+ | Esub -> fun x y -> x - y
+ | Eclt -> fun x y -> if x < y then 1 else 0
+ | Ecle -> fun x y -> if x <= y then 1 else 0
+ | Ecgt -> fun x y -> if x > y then 1 else 0
+ | Ecge -> fun x y -> if x >= y then 1 else 0
+ | Eceq -> fun x y -> if x = y then 1 else 0
+ | Ecne -> fun x y -> if x != y then 1 else 0
+
(* [eval_unop u x] évalue l'opération unaire [u] sur l'argument [x]. *)
let eval_unop (u: unop) : int -> int =
match u with
- | _ -> fun x -> 0
+ | Eneg -> fun x -> -x
(* [eval_eexpr st e] évalue l'expression [e] dans l'état [st]. Renvoie une
erreur si besoin. *)
let rec eval_eexpr st (e : expr) : int res =
- Error "eval_eexpr not implemented yet."
+ match e with
+ | Eint i -> OK i
+ | Evar s ->
+ (match Hashtbl.find_option st.env s with
+ | Some i -> OK i
+ | None -> Error "Variable is not defined")
+ | Ebinop (b, ex, ey) ->
+ (let res_x = eval_eexpr st ex
+ in let res_y = eval_eexpr st ey
+ in match res_x, res_y with
+ | Error msg, _ -> Error msg
+ | _, Error msg -> Error msg
+ | OK x, OK y -> OK (eval_binop b x y))
+ | Eunop (u, ex) ->
+ (let res_x = eval_eexpr st ex
+ in match res_x with
+ | Error msg -> Error msg
+ | OK x -> OK (eval_unop u x ))
(* [eval_einstr oc st ins] évalue l'instrution [ins] en partant de l'état [st].
@@ -35,7 +64,50 @@ let rec eval_eexpr st (e : expr) : int res =
- [st'] est l'état mis à jour. *)
let rec eval_einstr oc (st: int state) (ins: instr) :
(int option * int state) res =
- Error "eval_einstr not implemented yet."
+ match ins with
+ | Iassign (s, e) ->
+ (match eval_eexpr st e with
+ | Error msg -> Error msg
+ | OK v ->
+ let replace st s v =
+ let new_env = Hashtbl.copy st.env
+ in Hashtbl.replace new_env s v;
+ {st with env = new_env}
+ in OK (None, replace st s v))
+ | Iif (e, i1, i2) ->
+ (match eval_eexpr st e with
+ | Error msg -> Error msg
+ | OK v -> if v=1 then eval_einstr oc st i1 else eval_einstr oc st i2)
+ | Iwhile (e, i) ->
+ (match eval_eexpr st e with
+ | Error msg -> Error msg
+ | OK v ->
+ if v=1
+ then (let res_i = eval_einstr oc st i
+ in match res_i with
+ | Error msg -> Error msg
+ | OK (r_opt, next_st) -> match r_opt with
+ | None -> eval_einstr oc next_st (Iwhile (e, i))
+ | Some r -> OK (r_opt, next_st))
+ else OK(None, st))
+ | Iblock i_list ->
+ (match i_list with
+ | [] -> OK (None, st)
+ | i::rest ->
+ match eval_einstr oc st i with
+ | Error msg -> Error msg
+ | OK (Some r, next_st) -> OK (Some r, next_st)
+ | OK (None, next_st) -> eval_einstr oc next_st (Iblock rest))
+ | Ireturn e ->
+ (match eval_eexpr st e with
+ | Error msg -> Error msg
+ | OK v -> OK(Some v, st))
+ | Iprint e ->
+ (match eval_eexpr st e with
+ | Error msg -> Error msg
+ | OK v ->
+ Format.fprintf oc "%d\n" v;
+ OK(None, st))
(* [eval_efun oc st f fname vargs] évalue la fonction [f] (dont le nom est
[fname]) en partant de l'état [st], avec les arguments [vargs].
--
GitLab
From 230a40cd3f6ed654010becd793a33e4259cae0ca Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Sun, 9 Mar 2025 16:01:56 +0100
Subject: [PATCH 05/11] cfg
---
src/cfg_dead_assign.ml | 25 ++++++++++++++-----------
src/cfg_liveness.ml | 41 ++++++++++++++++++++++++++++++++++-------
src/cfg_nop_elim.ml | 24 ++++++++++++++++++------
src/elang.ml | 2 +-
4 files changed, 67 insertions(+), 25 deletions(-)
diff --git a/src/cfg_dead_assign.ml b/src/cfg_dead_assign.ml
index e35fc47..00c2b5b 100644
--- a/src/cfg_dead_assign.ml
+++ b/src/cfg_dead_assign.ml
@@ -14,22 +14,25 @@ open Options
nouvelle fonction, et [c] est un booléen qui indique si du progrès a été
fait. *)
let dead_assign_elimination_fun ({ cfgfunbody; _ } as f: cfg_fun) =
- let changed = ref false in
- let cfgfunbody =
- Hashtbl.map (fun (n: int) (m: cfg_node) ->
- match m with
- (* TODO *)
- | _ -> m
- ) cfgfunbody in
- ({ f with cfgfunbody }, !changed )
+ let changed = ref false
+ in let lives_in = live_cfg_fun f
+ in let lives_out n = live_after_node cfgfunbody n lives_in
+ in let cfgfunbody =
+ Hashtbl.map (fun (n: int) (m: cfg_node) ->
+ match m with
+ (* TODO *)
+ | Cassign (s, e, i) -> if (Set.mem s (lives_out n)) then m else (changed := true; Cnop i)
+ | _ -> m
+ ) cfgfunbody
+ in ({ f with cfgfunbody }, !changed )
(* Applique l'élimination de code mort autant de fois que nécessaire. Testez
notamment sur le fichier de test [basic/useless_assigns.e]. *)
let rec iter_dead_assign_elimination_fun f =
let f, c = dead_assign_elimination_fun f in
- (* TODO *)
- f
-
+ (* TODO *)
+ if c then iter_dead_assign_elimination_fun f else f
+
let dead_assign_elimination_gdef = function
Gfun f -> Gfun (iter_dead_assign_elimination_fun f)
diff --git a/src/cfg_liveness.ml b/src/cfg_liveness.ml
index 194a291..609e3ad 100644
--- a/src/cfg_liveness.ml
+++ b/src/cfg_liveness.ml
@@ -1,12 +1,17 @@
open Batteries
open Cfg
+open Utils
(* Analyse de vivacité *)
(* [vars_in_expr e] renvoie l'ensemble des variables qui apparaissent dans [e]. *)
let rec vars_in_expr (e: expr) =
(* TODO *)
- Set.empty
+ match e with
+ | Eint i -> Set.empty
+ | Evar s -> Set.singleton s
+ | Ebinop (b, e1, e2) -> Set.union (vars_in_expr e1) (vars_in_expr e2)
+ | Eunop (u, e) -> vars_in_expr e
(* [live_after_node cfg n] renvoie l'ensemble des variables vivantes après le
nœud [n] dans un CFG [cfg]. [lives] est l'état courant de l'analyse,
@@ -14,14 +19,26 @@ let rec vars_in_expr (e: expr) =
les valeurs sont les ensembles de variables vivantes avant chaque nœud. *)
let live_after_node cfg n (lives: (int, string Set.t) Hashtbl.t) : string Set.t =
(* TODO *)
- Set.empty
-
+ let in_succs_opt = Set.map (fun s -> Hashtbl.find_opt lives s) (succs cfg n)
+ in let in_succs = Set.filter_map (fun s -> s) in_succs_opt
+ in set_concat (Set.to_list in_succs)
(* [live_cfg_node node live_after] renvoie l'ensemble des variables vivantes
avant un nœud [node], étant donné l'ensemble [live_after] des variables
vivantes après ce nœud. *)
let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
(* TODO *)
- live_after
+ let use node =
+ match node with
+ | Cassign (s, e, i) -> vars_in_expr e
+ | Creturn e -> vars_in_expr e
+ | Cprint (e, i) -> vars_in_expr e
+ | Ccmp (e, i1, i2) -> vars_in_expr e
+ | Cnop (i) -> Set.empty
+ in let def node =
+ match node with
+ | Cassign (s, e, i) -> Set.singleton s
+ | _ -> Set.empty
+ in Set.union (use node) (Set.diff live_after (def node))
(* [live_cfg_nodes cfg lives] effectue une itération du calcul de point fixe.
@@ -31,12 +48,22 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
nœud a changé). *)
let live_cfg_nodes cfg (lives : (int, string Set.t) Hashtbl.t) =
(* TODO *)
- false
+ let changed = ref false in
+ Hashtbl.iter (fun n node ->
+ let new_alive_vars = live_cfg_node node (live_after_node cfg n lives)
+ in match Hashtbl.find_opt lives n with
+ | None -> changed := true; Hashtbl.replace lives n new_alive_vars
+ | Some alive_vars -> if not (Set.equal alive_vars new_alive_vars) then changed := true; Hashtbl.replace lives n new_alive_vars) cfg; !changed
+
(* [live_cfg_fun f] calcule l'ensemble des variables vivantes avant chaque nœud
du CFG en itérant [live_cfg_nodes] jusqu'à ce qu'un point fixe soit atteint.
*)
let live_cfg_fun (f: cfg_fun) : (int, string Set.t) Hashtbl.t =
- let lives = Hashtbl.create 17 in
+ let lives = Hashtbl.create 17 in
(* TODO *)
- lives
+ let cfg = f.cfgfunbody
+ in while live_cfg_nodes cfg lives do
+ ()
+ done;
+ lives
diff --git a/src/cfg_nop_elim.ml b/src/cfg_nop_elim.ml
index da45a5a..5d8f3c6 100644
--- a/src/cfg_nop_elim.ml
+++ b/src/cfg_nop_elim.ml
@@ -15,7 +15,9 @@ open Options
*)
let nop_transitions (cfgfunbody: (int, cfg_node) Hashtbl.t) : (int * int) list =
(* TODO *)
- []
+ Hashtbl.fold (fun n node acc -> match node with
+ | Cnop i -> (n, i)::acc
+ | _ -> acc) cfgfunbody []
(* [follow n l visited] donne le premier successeur à partir de [n] qui ne soit
@@ -26,9 +28,13 @@ let nop_transitions (cfgfunbody: (int, cfg_node) Hashtbl.t) : (int * int) list =
L'ensemble [visited] est utilisé pour éviter les boucles.
*)
-let rec follow (n: int) (l: (int * int) list) (visited: int Set.t) : int =
+let rec follow (nop: int) (l: (int * int) list) (visited: int Set.t) : int =
(* TODO *)
- n
+ if Set.mem nop visited
+ then nop
+ else match List.assoc_opt nop l with
+ | None -> nop
+ | Some m -> follow m l (Set.add nop visited)
(* [nop_transitions_closed] contient la liste [(n,s)] telle que l'instruction au
nœud [n] est le début d'une chaîne de NOPs qui termine au nœud [s]. Les
@@ -48,13 +54,19 @@ let nop_transitions_closed cfgfunbody =
liste [nop_succs] (telle que renvoyée par [nop_transitions_closed]). *)
let replace_succ nop_succs s =
(* TODO *)
- s
+ match List.assoc_opt s nop_succs with
+ | None -> s
+ | Some x -> x
(* [replace_succs nop_succs n] remplace le nœud [n] par un nœud équivalent où on
a remplacé les successeurs, en utilisant la liste [nop_succs]. *)
let replace_succs nop_succs (n: cfg_node) =
(* TODO *)
- n
+ match n with
+ | Cassign (s, e, i) -> Cassign (s, e, replace_succ nop_succs i)
+ | Cprint (e, i) -> Cprint (e, replace_succ nop_succs i)
+ | Ccmp (e, i1, i2) -> Ccmp (e, replace_succ nop_succs i1, replace_succ nop_succs i2)
+ | _ -> n
(* [nop_elim_fun f] applique la fonction [replace_succs] à chaque nœud du CFG. *)
let nop_elim_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
@@ -69,7 +81,7 @@ let nop_elim_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
*)
let cfgfunbody = Hashtbl.filter_map (fun n node ->
(* TODO *)
- Some node
+ if Set.is_empty (preds cfgfunbody n) && n!=cfgentry then None else Some (replace_succs nop_transf node)
) cfgfunbody in
(* La fonction renvoyée est composée du nouveau [cfgfunbody] que l'on vient de
calculer, et le point d'entrée est transformé en conséquence. *)
diff --git a/src/elang.ml b/src/elang.ml
index 3e6fcf0..7dc3280 100644
--- a/src/elang.ml
+++ b/src/elang.ml
@@ -6,7 +6,7 @@ type unop = Eneg
type expr =
Ebinop of binop * expr * expr
- | Eunop of unop * expr (*unused*)
+ | Eunop of unop * expr (*unused in grammar*)
| Eint of int
| Evar of string
--
GitLab
From d685e24da2e5a4103361a174918459a196463b87 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Sun, 9 Mar 2025 16:40:53 +0100
Subject: [PATCH 06/11] nop elimination
---
src/cfg_nop_elim.ml | 14 ++++++++++----
1 file changed, 10 insertions(+), 4 deletions(-)
diff --git a/src/cfg_nop_elim.ml b/src/cfg_nop_elim.ml
index 5d8f3c6..142d096 100644
--- a/src/cfg_nop_elim.ml
+++ b/src/cfg_nop_elim.ml
@@ -66,6 +66,7 @@ let replace_succs nop_succs (n: cfg_node) =
| Cassign (s, e, i) -> Cassign (s, e, replace_succ nop_succs i)
| Cprint (e, i) -> Cprint (e, replace_succ nop_succs i)
| Ccmp (e, i1, i2) -> Ccmp (e, replace_succ nop_succs i1, replace_succ nop_succs i2)
+ | Cnop i -> Cnop (replace_succ nop_succs i)
| _ -> n
(* [nop_elim_fun f] applique la fonction [replace_succs] à chaque nœud du CFG. *)
@@ -79,13 +80,18 @@ let nop_elim_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
(inaccessibles), et appliquer la fonction [replace_succs] aux nœuds qui
resteront.
*)
- let cfgfunbody = Hashtbl.filter_map (fun n node ->
(* TODO *)
- if Set.is_empty (preds cfgfunbody n) && n!=cfgentry then None else Some (replace_succs nop_transf node)
- ) cfgfunbody in
+ let cfgfunbody_corr_links = Hashtbl.map (fun n node ->
+ replace_succs nop_transf node
+ ) cfgfunbody
+ in let cfgfunbody_wout_inacc = Hashtbl.filter_map (fun n node ->
+ match node with
+ | Cnop i -> None
+ | _ -> if Set.is_empty (preds cfgfunbody_corr_links n) && n!=cfgentry then None else Some node
+ ) cfgfunbody_corr_links in
(* La fonction renvoyée est composée du nouveau [cfgfunbody] que l'on vient de
calculer, et le point d'entrée est transformé en conséquence. *)
- {f with cfgfunbody; cfgentry = replace_succ nop_transf cfgentry }
+ {f with cfgfunbody=cfgfunbody_wout_inacc; cfgentry = replace_succ nop_transf cfgentry }
let nop_elim_gdef gd =
match gd with
--
GitLab
From 22c3ed78a58447416d09ce734758990e26171313 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Wed, 12 Mar 2025 11:35:38 +0100
Subject: [PATCH 07/11] rtlgen and regalloc
---
src/linear_gen.ml | 34 ++++++++++++++++++++-------
src/regalloc.ml | 60 +++++++++++++++++++++++++++++++----------------
src/rtl_gen.ml | 31 +++++++++++++++++++++---
3 files changed, 94 insertions(+), 31 deletions(-)
diff --git a/src/linear_gen.ml b/src/linear_gen.ml
index c12bd04..cd83deb 100644
--- a/src/linear_gen.ml
+++ b/src/linear_gen.ml
@@ -19,23 +19,41 @@ let rec succs_of_rtl_instrs il : int list =
(* effectue un tri topologique des blocs. *)
let sort_blocks (nodes: (int, rtl_instr list) Hashtbl.t) entry =
- let rec add_block order n =
- (* TODO *)
- List.of_enum (Hashtbl.keys nodes)
+ let rec add_block order visited n =
+ (* TODO *)
+ List.of_enum (Hashtbl.keys nodes)
+ (*if Set.mem n visited
+ then order
+ else let succs = succs_of_rtl_instrs (Hashtbl.find nodes n)
+ in List.concat( (order@[n]) :: List.map (add_block [] (Set.add n visited)) succs )*)
in
- add_block [] entry
+ add_block [] Set.empty entry
(* Supprime les jumps inutiles (Jmp à un label défini juste en dessous). *)
let rec remove_useless_jumps (l: rtl_instr list) =
- (* TODO *)
- l
+ (* TODO *)
+ l
+ (*match l with
+ | [] -> []
+ | Rjmp l1::Rlabel l2::rest ->
+ if l1=l2
+ then Rlabel l2::remove_useless_jumps rest
+ else Rjmp l1::Rlabel l2::remove_useless_jumps rest
+ | i::rest -> i::remove_useless_jumps rest*)
(* Remove labels that are never jumped to. *)
let remove_useless_labels (l: rtl_instr list) =
- (* TODO *)
- l
+ (* TODO *)
+ l
+ (*List.filter (function
+ Rlabel i -> List.exists (
+ function
+ Rbranch(_, _, _, j) -> j = i
+ | Rjmp j -> j = i
+ | _ -> false) l
+ | _ -> true) l*)
let linear_of_rtl_fun
({ rtlfunargs; rtlfunbody; rtlfunentry; rtlfuninfo }: rtl_fun) =
diff --git a/src/regalloc.ml b/src/regalloc.ml
index c68b9fd..a843912 100644
--- a/src/regalloc.ml
+++ b/src/regalloc.ml
@@ -55,7 +55,7 @@ let regalloc_on_stack_fun (f: linear_fun) : ((reg, loc) Hashtbl.t * int)=
avec le registre-clé. Cela correspond à la relation d'adjacence dans le
graphe d'interférence. *)
-(* La fonction [add_to_interf rig x y] ajoute [y] Ã la liste des registres qui
+(* La fonction [add_to_interf rig x y] ajoute [y] Ã la liste des regiNosstres qui
interfèrent avec [x] dans le graphe [rig].
On pourra utiliser la fonction [Hashtbl.modify_def] qui permet de modifier la
@@ -79,7 +79,8 @@ let regalloc_on_stack_fun (f: linear_fun) : ((reg, loc) Hashtbl.t * int)=
let add_interf (rig : (reg, reg Set.t) Hashtbl.t) (x: reg) (y: reg) : unit =
(* TODO *)
- ()
+ Hashtbl.modify_def Set.empty x (Set.add y) rig;
+ Hashtbl.modify_def Set.empty y (Set.add x) rig
(* [make_interf_live rig live] ajoute des arcs dans le graphe d'interférence
@@ -89,7 +90,7 @@ let make_interf_live
(rig: (reg, reg Set.t) Hashtbl.t)
(live : (int, reg Set.t) Hashtbl.t) : unit =
(* TODO *)
- ()
+ Hashtbl.iter (fun i regs -> Set.iter (fun x -> Set.iter (fun y -> if x < y then add_interf rig x y) regs) regs) live
(* [build_interference_graph live_out] construit, en utilisant les fonctions que
vous avez écrites, le graphe d'interférence en fonction de la vivacité des
@@ -120,8 +121,11 @@ let build_interference_graph (live_out : (int, reg Set.t) Hashtbl.t) code : (reg
(* [remove_from_rig rig v] supprime le sommet [v] du graphe d'interférences
[rig]. *)
let remove_from_rig (rig : (reg, reg Set.t) Hashtbl.t) (v: reg) : unit =
- (* TODO *)
- ()
+ (* TODO *)
+ while Hashtbl.mem rig v do
+ Hashtbl.remove rig v
+ done;
+ Hashtbl.iter (fun x regs -> Hashtbl.modify x (Set.remove v) rig) rig
(* Type représentant les différentes décisions qui peuvent être prises par
@@ -159,8 +163,8 @@ type regalloc_decision =
possédant strictement moins de [n] voisins. Retourne [None] si aucun sommet
ne satisfait cette condition. *)
let pick_node_with_fewer_than_n_neighbors (rig : (reg, reg Set.t) Hashtbl.t) (n: int) : reg option =
- (* TODO *)
- None
+ (* TODO *)
+ Hashtbl.fold (fun x regs acc -> if (Set.cardinal regs) < n then Some x else acc) rig None
(* Lorsque la fonction précédente échoue (i.e. aucun sommet n'a moins de [n]
voisins), on choisit un pseudo-registre à évincer.
@@ -171,24 +175,30 @@ let pick_node_with_fewer_than_n_neighbors (rig : (reg, reg Set.t) Hashtbl.t) (n:
[pick_spilling_candidate rig] retourne donc le pseudo-registre [r] qui a le
plus de voisins dans [rig], ou [None] si [rig] est vide. *)
let pick_spilling_candidate (rig : (reg, reg Set.t) Hashtbl.t) : reg option =
- (* TODO *)
- None
+ (* TODO *)
+ let candidate_number_of_neighbours = Hashtbl.fold (fun x regs acc ->
+ match acc with
+ | None -> Some (x, Set.cardinal regs)
+ | Some (y, k) -> if Set.cardinal regs > k then Some (x, Set.cardinal regs) else acc
+ ) rig None
+ in match candidate_number_of_neighbours with
+ | None -> None
+ | Some (y, k) -> Some y
(* [make_stack rig stack ncolors] construit la pile, selon l'algorithme vu en
cours (slide 26 du cours "Allocation de registres"
présent sur Edunao.) *)
let rec make_stack (rig : (reg, reg Set.t) Hashtbl.t) (stack : regalloc_decision list) (ncolors: int) : regalloc_decision list =
- (* TODO *)
- stack
+ (* TODO *)
+ match pick_node_with_fewer_than_n_neighbors rig ncolors with
+ | Some r -> remove_from_rig rig r; make_stack rig (NoSpill r :: stack) ncolors
+ | None ->
+ match pick_spilling_candidate rig with
+ | Some r -> remove_from_rig rig r; make_stack rig (Spill r :: stack) ncolors
+ | None -> stack
(* Maintenant que nous avons une pile de [regalloc_decision], il est temps de
- colorer notre graphe, i.e. associer une couleur (un numéro de registre
- physique) Ã chaque pseudo-registre. Nous allons parcourir la pile et pour
- chaque décision :
-
- - Â [Spill r] : associer un emplacement sur la pile au pseudo-registre [r]. On
- choisira l'emplacement [next_stack_slot].
-
+ colorer notre graphe, i.e. associer une couleur (un numéro de restack@[NoSpill r]
- [NoSpill r] : associer une couleur (un registre) physique au
pseudo-registre [r]. On choisira une couleur qui n'est pas déjà associée à un
voisin de [r] dans [rig].
@@ -218,8 +228,18 @@ let allocate (allocation: (reg, loc) Hashtbl.t) (rig: (reg, reg Set.t) Hashtbl.t
(all_colors: int Set.t)
(next_stack_slot: int) (decision: regalloc_decision)
: int =
- (* TODO *)
- next_stack_slot
+ (* TODO *)
+ match decision with
+ | Spill r -> Hashtbl.add allocation r (Stk next_stack_slot); next_stack_slot-1
+ | NoSpill r -> let neighbours = Hashtbl.find rig r
+ in let neighbour_colors = Set.filter_map (
+ fun neighbour -> match Hashtbl.find_opt allocation neighbour with
+ | Some (Reg color) -> Some color
+ | _ -> None
+ ) neighbours
+ in let available_colors = Set.diff all_colors neighbour_colors
+ in let chosen_color = Set.choose available_colors
+ in Hashtbl.add allocation r (Reg chosen_color); next_stack_slot
(* [regalloc_fun f live_out all_colors] effectue l'allocation de registres pour
la fonction [f].
diff --git a/src/rtl_gen.ml b/src/rtl_gen.ml
index ce1eb8f..7955b3f 100644
--- a/src/rtl_gen.ml
+++ b/src/rtl_gen.ml
@@ -43,7 +43,16 @@ let find_var (next_reg, var2reg) v =
- [var2reg] est la nouvelle association nom de variable/registre.
*)
let rec rtl_instrs_of_cfg_expr (next_reg, var2reg) (e: expr) =
- (next_reg, [], next_reg, var2reg)
+ match e with
+ | Evar v -> let r, next_reg', var2reg' = find_var (next_reg, var2reg) v in (r, [], next_reg', var2reg')
+ | Eint i -> (next_reg, [Rconst(next_reg, i)], next_reg+1, var2reg)
+ | Ebinop (b, e1, e2) ->
+ let r1, l1, next_reg1, var2reg1 = rtl_instrs_of_cfg_expr (next_reg, var2reg) e1
+ in let r2, l2, next_reg2, var2reg2 = rtl_instrs_of_cfg_expr (next_reg1, var2reg1) e2
+ in (next_reg2, l1@l2@[Rbinop(b, next_reg2, r1, r2)], next_reg2+1, var2reg2)
+ | Eunop (u, e) ->
+ let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) e
+ in (next_reg', l@[Runop(u, next_reg', r)], next_reg'+1, var2reg')
let is_cmp_op =
function Eclt -> Some Rclt
@@ -64,8 +73,24 @@ let rtl_cmp_of_cfg_expr (e: expr) =
let rtl_instrs_of_cfg_node ((next_reg:int), (var2reg: (string*int) list)) (c: cfg_node) =
- (* TODO *)
- ([], next_reg, var2reg)
+ (* TODO *)
+ match c with
+ | Cassign (s, e, i) ->
+ let r_e, l, next_reg1, var2reg1 = rtl_instrs_of_cfg_expr (next_reg, var2reg) e
+ in let r_s, next_reg2, var2reg2 = find_var (next_reg1, var2reg1) s
+ in (l@[Rmov(r_s, r_e); Rjmp i], next_reg2, var2reg2)
+ | Creturn e ->
+ let r_e, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) e
+ in (l@[Rret r_e], next_reg', var2reg')
+ | Cprint (e, i) ->
+ let r_e, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) e
+ in (l@[Rprint r_e; Rjmp i], next_reg', var2reg')
+ | Ccmp (e, i1, i2) ->
+ let cmp, e1, e2 = rtl_cmp_of_cfg_expr e
+ in let r1, l1, next_reg1, var2reg1 = rtl_instrs_of_cfg_expr (next_reg, var2reg) e1
+ in let r2, l2, next_reg2, var2reg2 = rtl_instrs_of_cfg_expr (next_reg1, var2reg1) e2
+ in (l1@l2@[Rbranch(cmp, r1, r2, i1)]@[Rjmp i2], next_reg2, var2reg2)
+ | Cnop i -> ([Rjmp i], next_reg, var2reg)
let rtl_instrs_of_cfg_fun cfgfunname ({ cfgfunargs; cfgfunbody; cfgentry }: cfg_fun) =
let (rargs, next_reg, var2reg) =
--
GitLab
From ebad7c57fc703eb8df6de8b51ec753cc1a10877b Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Thu, 13 Mar 2025 19:03:02 +0100
Subject: [PATCH 08/11] Functions : parser and E
---
expr_grammar_action.g | 32 +++++-
src/ast.ml | 7 +-
src/elang.ml | 4 +-
src/elang_gen.ml | 15 +++
src/elang_print.ml | 5 +
src/elang_run.ml | 110 ++++++++++++++-------
src/regalloc.ml | 6 +-
tests/Makefile | 2 +-
tests/funcall/argswap.e.expect_lexer | 8 +-
tests/funcall/print_and_fun.e.expect_lexer | 4 +-
10 files changed, 142 insertions(+), 51 deletions(-)
diff --git a/expr_grammar_action.g b/expr_grammar_action.g
index 9d5d588..b871578 100644
--- a/expr_grammar_action.g
+++ b/expr_grammar_action.g
@@ -10,6 +10,9 @@ non-terminals ADD_EXPRS ADD_EXPR
non-terminals MUL_EXPRS MUL_EXPR
non-terminals CMP_EXPRS CMP_EXPR
non-terminals EQ_EXPRS EQ_EXPR
+
+non-terminals AFTER_IDENTIFIER LARGS REST_ARGS
+
axiom S
{
@@ -20,6 +23,10 @@ axiom S
open Batteries
open Utils
+ type after_id =
+ | Assign of tree
+ | Funcall of tree list
+ | Nothing
(* TODO *)
let rec resolve_associativity (term : tree) (other : (tag * tree) list) =
@@ -40,6 +47,11 @@ LPARAMS -> { [] }
REST_PARAMS -> SYM_COMMA LPARAMS { $2 }
REST_PARAMS -> { [] }
+LARGS -> EXPR REST_ARGS { $1::$2 }
+LARGS -> { [] }
+REST_ARGS -> SYM_COMMA LARGS { $2 }
+REST_ARGS -> { [] }
+
LINSTRS -> INSTR INSTRS { Node(Tblock, $1::$2) }
LINSTRS -> { NullLeaf }
INSTRS -> INSTR INSTRS { $1::$2 }
@@ -49,9 +61,18 @@ INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RB
INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS INSTR { Node(Twhile, [$3; $5]) }
INSTR -> SYM_RETURN EXPR SYM_SEMICOLON { Node(Treturn, [$2]) }
INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON { Node(Tprint, [$3]) }
-INSTR -> IDENTIFIER SYM_ASSIGN EXPR SYM_SEMICOLON { Node(Tassign, [$1; $3]) }
+INSTR -> IDENTIFIER AFTER_IDENTIFIER SYM_SEMICOLON {
+ match $2 with
+ | Assign exp -> Node(Tassign, [$1; exp])
+ | Funcall args -> Node(Tcall, [$1; Node(Targs, args)])
+ | _ -> $1
+}
INSTR -> SYM_LBRACE LINSTRS SYM_RBRACE { $2 }
+AFTER_IDENTIFIER -> SYM_ASSIGN EXPR { Assign $2 }
+AFTER_IDENTIFIER -> SYM_LPARENTHESIS LARGS SYM_RPARENTHESIS { Funcall $2 }
+AFTER_IDENTIFIER -> { Nothing }
+
ELSE -> SYM_ELSE SYM_LBRACE LINSTRS SYM_RBRACE { $3 }
ELSE -> { NullLeaf }
@@ -59,6 +80,8 @@ EXPR -> EQ_EXPR EQ_EXPRS { resolve_associativity $1 $2 }
EQ_EXPR -> CMP_EXPR CMP_EXPRS { resolve_associativity $1 $2 }
CMP_EXPR -> ADD_EXPR ADD_EXPRS { resolve_associativity $1 $2 }
ADD_EXPR -> MUL_EXPR MUL_EXPRS { resolve_associativity $1 $2 }
+ADD_EXPR -> SYM_MINUS MUL_EXPR MUL_EXPRS { resolve_associativity (Node(Tneg, [$2])) $3 }
+ADD_EXPR -> SYM_PLUS MUL_EXPR MUL_EXPRS { resolve_associativity $2 $3 }
MUL_EXPR -> FACTOR { $1 }
EQ_EXPRS -> SYM_EQUALITY EQ_EXPR EQ_EXPRS { (Tceq, $2)::$3 }
@@ -81,7 +104,12 @@ MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS { (Tmod, $2)::$3 }
MUL_EXPRS -> { [] }
FACTOR -> INTEGER { $1 }
-FACTOR -> IDENTIFIER { $1 }
+FACTOR -> IDENTIFIER AFTER_IDENTIFIER {
+ match $2 with
+ | Funcall args -> Node(Tcall, [$1; Node(Targs, args)])
+ | Nothing -> $1
+ | _ -> $1
+}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS { $2 }
IDENTIFIER -> SYM_IDENTIFIER {StringLeaf $1}
diff --git a/src/ast.ml b/src/ast.ml
index bfd93a8..cfb67d6 100644
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -28,9 +28,9 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint
| Tclt | Tcgt | Tcle | Tcge | Tceq | Tne
| Tneg
| Tlistglobdef
- | Tfundef | Tfunname | Tfunargs | Tfunbody
+ | Tfundef | Tfunname | Tfunargs | Tfunbody | Tcall
| Tassignvar
- | Targ
+ | Targ | Targs
type tree = | Node of tag * tree list
| StringLeaf of string
@@ -73,7 +73,8 @@ let string_of_tag = function
| Tfunbody -> "Tfunbody"
| Tassignvar -> "Tassignvar"
| Targ -> "Targ"
-
+ | Tcall -> "Tcall"
+ | Targs -> "Targs"
(* Écrit un fichier .dot qui correspond à un AST *)
let rec draw_ast a next =
diff --git a/src/elang.ml b/src/elang.ml
index 7dc3280..38b4f66 100644
--- a/src/elang.ml
+++ b/src/elang.ml
@@ -6,9 +6,10 @@ type unop = Eneg
type expr =
Ebinop of binop * expr * expr
- | Eunop of unop * expr (*unused in grammar*)
+ | Eunop of unop * expr
| Eint of int
| Evar of string
+ | Ecall of string * expr list
type instr =
| Iassign of string * expr
@@ -17,6 +18,7 @@ type instr =
| Iblock of instr list
| Ireturn of expr
| Iprint of expr
+ | Icall of string * expr list
type efun = {
funargs: ( string ) list;
diff --git a/src/elang_gen.ml b/src/elang_gen.ml
index 86761b7..1d4db2d 100644
--- a/src/elang_gen.ml
+++ b/src/elang_gen.ml
@@ -54,6 +54,16 @@ let rec make_eexpr_of_ast (a: tree) : expr res =
| Error msg, _ -> Error msg
| _, Error msg -> Error msg
| OK expr1, OK expr2 -> OK (Ebinop (binop_of_tag t, expr1, expr2)))
+ | Node(Tneg, [e]) ->
+ (let res = make_eexpr_of_ast e
+ in match res with
+ | Error msg -> Error msg
+ | OK expr -> OK (Eunop (Eneg, expr)))
+ | Node(Tcall, [StringLeaf f; Node(Targs, args)]) ->
+ (let res = list_map_res make_eexpr_of_ast args
+ in match res with
+ | Error msg -> Error msg
+ | OK exprs -> OK (Ecall (f, exprs)))
| _ ->
Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
(string_of_ast a))
@@ -103,6 +113,11 @@ let rec make_einstr_of_ast (a: tree) : instr res =
in match res_of_e with
| OK exp -> OK (Iprint exp)
| Error msg -> Error msg)
+ | Node(Tcall, [StringLeaf f; Node(Targs, args)]) ->
+ (let res = list_map_res make_eexpr_of_ast args
+ in match res with
+ | Error msg -> Error msg
+ | OK exprs -> OK (Icall (f, exprs)))
| NullLeaf -> OK (Iblock [])
| _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
(string_of_ast a))
diff --git a/src/elang_print.ml b/src/elang_print.ml
index 2da36d9..8f7f8cf 100644
--- a/src/elang_print.ml
+++ b/src/elang_print.ml
@@ -26,6 +26,7 @@ let rec dump_eexpr = function
| Eunop(u, e) -> Printf.sprintf "(%s %s)" (dump_unop u) (dump_eexpr e)
| Eint i -> Printf.sprintf "%d" i
| Evar s -> Printf.sprintf "%s" s
+ | Ecall (f, args) -> Printf.sprintf "%s(%s)" f (String.concat ", " (List.map dump_eexpr args))
let indent_size = 2
let spaces n =
@@ -58,6 +59,10 @@ let rec dump_einstr_rec indent oc i =
| Iprint(e) ->
print_spaces oc indent;
Format.fprintf oc "print %s;\n" (dump_eexpr e)
+ | Icall(f, args) ->
+ print_spaces oc indent;
+ Format.fprintf oc "%s(%s);\n" f (String.concat ", " (List.map dump_eexpr args))
+
let dump_einstr oc i = dump_einstr_rec 0 oc i
diff --git a/src/elang_run.ml b/src/elang_run.ml
index 13afe7c..e4509f6 100644
--- a/src/elang_run.ml
+++ b/src/elang_run.ml
@@ -30,26 +30,49 @@ let eval_unop (u: unop) : int -> int =
(* [eval_eexpr st e] évalue l'expression [e] dans l'état [st]. Renvoie une
erreur si besoin. *)
-let rec eval_eexpr st (e : expr) : int res =
+let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
match e with
- | Eint i -> OK i
+ | Eint i -> OK (i, st)
| Evar s ->
(match Hashtbl.find_option st.env s with
- | Some i -> OK i
+ | Some i -> OK (i, st)
| None -> Error "Variable is not defined")
| Ebinop (b, ex, ey) ->
- (let res_x = eval_eexpr st ex
- in let res_y = eval_eexpr st ey
- in match res_x, res_y with
- | Error msg, _ -> Error msg
- | _, Error msg -> Error msg
- | OK x, OK y -> OK (eval_binop b x y))
+ (let res_x = eval_eexpr oc st ep ex
+ in match res_x with
+ | Error msg -> Error msg
+ | OK (x, st') ->
+ let res_y = eval_eexpr oc st' ep ey
+ in match res_y with
+ | Error msg -> Error msg
+ | OK (y, st'') -> OK (eval_binop b x y, st''))
| Eunop (u, ex) ->
- (let res_x = eval_eexpr st ex
+ (let res_x = eval_eexpr oc st ep ex
in match res_x with
| Error msg -> Error msg
- | OK x -> OK (eval_unop u x ))
-
+ | OK (x, st') -> OK (eval_unop u x, st'))
+ | Ecall (f, args) ->
+ let (res : (int list * int state) res) = List.fold_left (
+ fun (acc : (int list * int state) res) (arg : expr) ->
+ match acc with
+ | Error msg -> Error msg
+ | OK (l, st') ->
+ match eval_eexpr oc st' ep arg with
+ | Error msg -> Error msg
+ | OK (i, st'') -> OK ((l@[i]), st'')
+ ) (OK([], st)) args
+ in match res with
+ | Error msg -> Error msg
+ | OK (int_args, st') ->
+ match find_function ep f with
+ | Error msg -> Error msg
+ | OK found_f ->
+ match eval_efun oc st' ep found_f f int_args with
+ | Error msg -> Error msg
+ | OK (None, st'') -> Error (Format.sprintf "E: Function %s doesn't have a return value.\n" f)
+ | OK (Some ret, st'') -> OK (ret, st'')
+
+
(* [eval_einstr oc st ins] évalue l'instrution [ins] en partant de l'état [st].
Le paramètre [oc] est un "output channel", dans lequel la fonction "print"
@@ -62,59 +85,78 @@ let rec eval_eexpr st (e : expr) : int res =
lieu et que l'exécution doit continuer.
- [st'] est l'état mis à jour. *)
-let rec eval_einstr oc (st: int state) (ins: instr) :
+and eval_einstr oc (st: int state) (ep: eprog) (ins: instr) :
(int option * int state) res =
match ins with
| Iassign (s, e) ->
- (match eval_eexpr st e with
+ (match eval_eexpr oc st ep e with
| Error msg -> Error msg
- | OK v ->
+ | OK (v, st') ->
let replace st s v =
let new_env = Hashtbl.copy st.env
in Hashtbl.replace new_env s v;
{st with env = new_env}
- in OK (None, replace st s v))
+ in OK (None, replace st' s v))
| Iif (e, i1, i2) ->
- (match eval_eexpr st e with
+ (match eval_eexpr oc st ep e with
| Error msg -> Error msg
- | OK v -> if v=1 then eval_einstr oc st i1 else eval_einstr oc st i2)
+ | OK (v, st') -> if v = 1 then eval_einstr oc st' ep i1 else eval_einstr oc st' ep i2)
| Iwhile (e, i) ->
- (match eval_eexpr st e with
+ (match eval_eexpr oc st ep e with
| Error msg -> Error msg
- | OK v ->
- if v=1
- then (let res_i = eval_einstr oc st i
+ | OK (v, st') ->
+ if v = 1
+ then (let res_i = eval_einstr oc st' ep i
in match res_i with
| Error msg -> Error msg
| OK (r_opt, next_st) -> match r_opt with
- | None -> eval_einstr oc next_st (Iwhile (e, i))
+ | None -> eval_einstr oc next_st ep (Iwhile (e, i))
| Some r -> OK (r_opt, next_st))
- else OK(None, st))
+ else OK(None, st'))
| Iblock i_list ->
(match i_list with
| [] -> OK (None, st)
| i::rest ->
- match eval_einstr oc st i with
+ match eval_einstr oc st ep i with
| Error msg -> Error msg
| OK (Some r, next_st) -> OK (Some r, next_st)
- | OK (None, next_st) -> eval_einstr oc next_st (Iblock rest))
+ | OK (None, next_st) -> eval_einstr oc next_st ep (Iblock rest))
| Ireturn e ->
- (match eval_eexpr st e with
+ (match eval_eexpr oc st ep e with
| Error msg -> Error msg
- | OK v -> OK(Some v, st))
+ | OK (v, st') -> OK(Some v, st'))
| Iprint e ->
- (match eval_eexpr st e with
+ (match eval_eexpr oc st ep e with
| Error msg -> Error msg
- | OK v ->
+ | OK (v, st') ->
Format.fprintf oc "%d\n" v;
- OK(None, st))
+ OK(None, st'))
+ | Icall (f, args) ->
+ let (res : (int list * int state) res) = List.fold_left (
+ fun (acc : (int list * int state) res) (arg : expr) ->
+ match acc with
+ | Error msg -> Error msg
+ | OK (l, st') ->
+ match eval_eexpr oc st' ep arg with
+ | Error msg -> Error msg
+ | OK (i, st'') -> OK ((l@[i]), st'')
+ ) (OK([], st)) args
+ in match res with
+ | Error msg -> Error msg
+ | OK (int_args, st') ->
+ match find_function ep f with
+ | Error msg -> Error msg
+ | OK found_f ->
+ match eval_efun oc st' ep found_f f int_args with
+ | Error msg -> Error msg
+ | OK (_, st'') -> OK (None, st'')
(* [eval_efun oc st f fname vargs] évalue la fonction [f] (dont le nom est
[fname]) en partant de l'état [st], avec les arguments [vargs].
Cette fonction renvoie un couple (ret, st') avec la même signification que
pour [eval_einstr]. *)
-let eval_efun oc (st: int state) ({ funargs; funbody}: efun)
+and eval_efun oc (st: int state) ep ({ funargs; funbody}: efun)
(fname: string) (vargs: int list)
: (int option * int state) res =
(* L'environnement d'une fonction (mapping des variables locales vers leurs
@@ -126,7 +168,7 @@ let eval_efun oc (st: int state) ({ funargs; funbody}: efun)
let env = Hashtbl.create 17 in
match List.iter2 (fun a v -> Hashtbl.replace env a v) funargs vargs with
| () ->
- eval_einstr oc { st with env } funbody >>= fun (v, st') ->
+ eval_einstr oc { st with env } ep funbody >>= fun (v, st') ->
OK (v, { st' with env = env_save })
| exception Invalid_argument _ ->
Error (Format.sprintf
@@ -157,5 +199,5 @@ let eval_eprog oc (ep: eprog) (memsize: int) (params: int list)
(* ne garde que le nombre nécessaire de paramètres pour la fonction "main". *)
let n = List.length f.funargs in
let params = take n params in
- eval_efun oc st f "main" params >>= fun (v, _) ->
+ eval_efun oc st ep f "main" params >>= fun (v, _) ->
OK v
diff --git a/src/regalloc.ml b/src/regalloc.ml
index a843912..897da01 100644
--- a/src/regalloc.ml
+++ b/src/regalloc.ml
@@ -92,6 +92,7 @@ let make_interf_live
(* TODO *)
Hashtbl.iter (fun i regs -> Set.iter (fun x -> Set.iter (fun y -> if x < y then add_interf rig x y) regs) regs) live
+
(* [build_interference_graph live_out] construit, en utilisant les fonctions que
vous avez écrites, le graphe d'interférence en fonction de la vivacité des
variables à la sortie des nœuds donné par [live_out].
@@ -122,12 +123,9 @@ let build_interference_graph (live_out : (int, reg Set.t) Hashtbl.t) code : (reg
[rig]. *)
let remove_from_rig (rig : (reg, reg Set.t) Hashtbl.t) (v: reg) : unit =
(* TODO *)
- while Hashtbl.mem rig v do
- Hashtbl.remove rig v
- done;
+ Hashtbl.remove rig v;
Hashtbl.iter (fun x regs -> Hashtbl.modify x (Set.remove v) rig) rig
-
(* Type représentant les différentes décisions qui peuvent être prises par
l'allocateur de registres.
diff --git a/tests/Makefile b/tests/Makefile
index 7f5a992..ef3fa0a 100644
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -1,7 +1,7 @@
# 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
-FILES := $(if $(DIR),$(DIR),basic/*.e)
+FILES := $(if $(DIR),$(DIR),funcall/*.e)
OPTS := $(if $(OPTS), $(OPTS),)
diff --git a/tests/funcall/argswap.e.expect_lexer b/tests/funcall/argswap.e.expect_lexer
index 2c8a87d..89b98c3 100644
--- a/tests/funcall/argswap.e.expect_lexer
+++ b/tests/funcall/argswap.e.expect_lexer
@@ -5,12 +5,12 @@ SYM_COMMA
SYM_IDENTIFIER(b)
SYM_RPARENTHESIS
SYM_LBRACE
-SYM_IDENTIFIER(print)
+SYM_PRINT
SYM_LPARENTHESIS
SYM_IDENTIFIER(a)
SYM_RPARENTHESIS
SYM_SEMICOLON
-SYM_IDENTIFIER(print)
+SYM_PRINT
SYM_LPARENTHESIS
SYM_IDENTIFIER(b)
SYM_RPARENTHESIS
@@ -30,12 +30,12 @@ SYM_COMMA
SYM_IDENTIFIER(b)
SYM_RPARENTHESIS
SYM_LBRACE
-SYM_IDENTIFIER(print)
+SYM_PRINT
SYM_LPARENTHESIS
SYM_IDENTIFIER(a)
SYM_RPARENTHESIS
SYM_SEMICOLON
-SYM_IDENTIFIER(print)
+SYM_PRINT
SYM_LPARENTHESIS
SYM_IDENTIFIER(b)
SYM_RPARENTHESIS
diff --git a/tests/funcall/print_and_fun.e.expect_lexer b/tests/funcall/print_and_fun.e.expect_lexer
index 834218f..d8e4934 100644
--- a/tests/funcall/print_and_fun.e.expect_lexer
+++ b/tests/funcall/print_and_fun.e.expect_lexer
@@ -21,12 +21,12 @@ SYM_LPARENTHESIS
SYM_INTEGER(8)
SYM_RPARENTHESIS
SYM_SEMICOLON
-SYM_IDENTIFIER(print)
+SYM_PRINT
SYM_LPARENTHESIS
SYM_IDENTIFIER(a)
SYM_RPARENTHESIS
SYM_SEMICOLON
-SYM_IDENTIFIER(print)
+SYM_PRINT
SYM_LPARENTHESIS
SYM_IDENTIFIER(b)
SYM_RPARENTHESIS
--
GitLab
From cefba8486c1a2c84253ba957f83180d862fd8a54 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Fri, 14 Mar 2025 10:24:44 +0100
Subject: [PATCH 09/11] functions : CFG
---
src/cfg.ml | 9 ++++--
src/cfg_gen.ml | 9 ++++++
src/cfg_liveness.ml | 2 ++
src/cfg_nop_elim.ml | 3 +-
src/cfg_print.ml | 6 ++--
src/cfg_run.ml | 75 +++++++++++++++++++++++++++++++--------------
src/elang_run.ml | 2 +-
7 files changed, 77 insertions(+), 29 deletions(-)
diff --git a/src/cfg.ml b/src/cfg.ml
index 7c4cb02..2a60c97 100644
--- a/src/cfg.ml
+++ b/src/cfg.ml
@@ -8,6 +8,7 @@ type expr =
| Eunop of unop * expr
| Eint of int
| Evar of string
+ | Ecall of string * expr list
type cfg_node =
| Cassign of string * expr * int
@@ -15,6 +16,7 @@ type cfg_node =
| Cprint of expr * int
| Ccmp of expr * int * int
| Cnop of int
+ | Ccall of string * expr list * int
type cfg_fun = {
cfgfunargs: string list;
@@ -35,7 +37,7 @@ let succs cfg n =
| Some (Creturn _) -> Set.empty
| Some (Ccmp (_, s1, s2)) -> Set.of_list [s1;s2]
| Some (Cnop s) -> Set.singleton s
-
+ | Some (Ccall (_, _, s)) -> Set.singleton s
(* [preds cfg n] donne l'ensemble des prédécesseurs d'un nœud [n] dans un CFG [cfg]
*)
@@ -44,7 +46,8 @@ let preds cfgfunbody n =
match m' with
| Cassign (_, _, s)
| Cprint (_, s)
- | Cnop s -> if s = n then Set.add m acc else acc
+ | Cnop s
+ | Ccall (_, _, s) -> if s = n then Set.add m acc else acc
| Creturn _ -> acc
| Ccmp (_, s1, s2) -> if s1 = n || s2 = n then Set.add m acc else acc
) cfgfunbody Set.empty
@@ -62,6 +65,7 @@ let rec size_expr (e: expr) : int =
| Eunop (u, e) -> size_unop u (size_expr e)
| Eint _ -> 1
| Evar _ -> 1
+ | Ecall (_, args) -> 1 + List.fold_left (fun acc arg -> acc + size_expr arg) 0 args
let size_instr (i: cfg_node) : int =
match (i : cfg_node) with
@@ -70,6 +74,7 @@ let size_instr (i: cfg_node) : int =
| Cprint (e, _) -> 1 + (size_expr e)
| Ccmp (e, _, _) -> 1 + size_expr e
| Cnop _ -> 1
+ | Ccall (_, args, _) -> 1 + List.fold_left (fun acc arg -> acc + size_expr arg) 0 args
let size_fun f =
Hashtbl.fold (fun _ v acc -> acc + size_instr v) f 0
diff --git a/src/cfg_gen.ml b/src/cfg_gen.ml
index 18509ef..ff2aa1b 100644
--- a/src/cfg_gen.ml
+++ b/src/cfg_gen.ml
@@ -25,6 +25,9 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res =
| Elang.Eint i -> OK (Eint i)
| Elang.Evar v ->
OK (Evar v)
+ | Elang.Ecall (f, args) ->
+ list_map_res cfg_expr_of_eexpr args >>= fun es ->
+ OK (Ecall (f, es))
(* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond
to the E instruction [i].
@@ -70,6 +73,11 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
cfg_expr_of_eexpr e >>= fun e ->
Hashtbl.replace cfg next (Cprint (e,succ));
OK (next, next + 1)
+ | Elang.Icall (f, args) ->
+ list_map_res cfg_expr_of_eexpr args >>= fun es ->
+ Hashtbl.replace cfg next (Ccall (f, es, succ));
+ OK (next, next + 1)
+
(* Some nodes may be unreachable after the CFG is entirely generated. The
[reachable_nodes n cfg] constructs the set of node identifiers that are
@@ -86,6 +94,7 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
| Some (Creturn _) -> reach
| Some (Ccmp (_, s1, s2)) ->
reachable_aux s1 (reachable_aux s2 reach)
+ | Some (Ccall (_, _, succ)) -> reachable_aux succ reach
in reachable_aux n Set.empty
(* [cfg_fun_of_efun f] builds the CFG for E function [f]. *)
diff --git a/src/cfg_liveness.ml b/src/cfg_liveness.ml
index 609e3ad..aa40206 100644
--- a/src/cfg_liveness.ml
+++ b/src/cfg_liveness.ml
@@ -12,6 +12,7 @@ let rec vars_in_expr (e: expr) =
| Evar s -> Set.singleton s
| Ebinop (b, e1, e2) -> Set.union (vars_in_expr e1) (vars_in_expr e2)
| Eunop (u, e) -> vars_in_expr e
+ | Ecall (f, args) -> set_concat (List.map vars_in_expr args)
(* [live_after_node cfg n] renvoie l'ensemble des variables vivantes après le
nœud [n] dans un CFG [cfg]. [lives] est l'état courant de l'analyse,
@@ -34,6 +35,7 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
| Cprint (e, i) -> vars_in_expr e
| Ccmp (e, i1, i2) -> vars_in_expr e
| Cnop (i) -> Set.empty
+ | Ccall (f, args, i) -> vars_in_expr (Ecall (f, args))
in let def node =
match node with
| Cassign (s, e, i) -> Set.singleton s
diff --git a/src/cfg_nop_elim.ml b/src/cfg_nop_elim.ml
index 142d096..dba2b51 100644
--- a/src/cfg_nop_elim.ml
+++ b/src/cfg_nop_elim.ml
@@ -67,7 +67,8 @@ let replace_succs nop_succs (n: cfg_node) =
| Cprint (e, i) -> Cprint (e, replace_succ nop_succs i)
| Ccmp (e, i1, i2) -> Ccmp (e, replace_succ nop_succs i1, replace_succ nop_succs i2)
| Cnop i -> Cnop (replace_succ nop_succs i)
- | _ -> n
+ | Creturn e -> Creturn e
+ | Ccall (f, args, i) -> Ccall (f, args, replace_succ nop_succs i)
(* [nop_elim_fun f] applique la fonction [replace_succs] à chaque nœud du CFG. *)
let nop_elim_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
diff --git a/src/cfg_print.ml b/src/cfg_print.ml
index 6ec810a..a452410 100644
--- a/src/cfg_print.ml
+++ b/src/cfg_print.ml
@@ -8,6 +8,7 @@ let rec dump_cfgexpr : expr -> string = function
| Eunop(u, e) -> Format.sprintf "(%s %s)" (dump_unop u) (dump_cfgexpr e)
| Eint i -> Format.sprintf "%d" i
| Evar s -> Format.sprintf "%s" s
+ | Ecall (f, args) -> Format.sprintf "%s(%s)" f (String.concat ", " (List.map dump_cfgexpr args))
let dump_list_cfgexpr l =
l |> List.map dump_cfgexpr |> String.concat ", "
@@ -17,7 +18,8 @@ let dump_arrows oc fname n (node: cfg_node) =
match node with
| Cassign (_, _, succ)
| Cprint (_, succ)
- | Cnop succ ->
+ | Cnop succ
+ | Ccall (_, _, succ) ->
Format.fprintf oc "n_%s_%d -> n_%s_%d\n" fname n fname succ
| Creturn _ -> ()
| Ccmp (_, succ1, succ2) ->
@@ -32,7 +34,7 @@ let dump_cfg_node oc (node: cfg_node) =
| Creturn e -> Format.fprintf oc "return %s" (dump_cfgexpr e)
| Ccmp (e, _, _) -> Format.fprintf oc "%s" (dump_cfgexpr e)
| Cnop _ -> Format.fprintf oc "nop"
-
+ | Ccall (f, args, _) -> Format.fprintf oc "%s(%s)" f (String.concat ", " (List.map dump_cfgexpr args))
let dump_liveness_state oc ht state =
Hashtbl.iter (fun n cn ->
diff --git a/src/cfg_run.ml b/src/cfg_run.ml
index 6557acd..e2e4212 100644
--- a/src/cfg_run.ml
+++ b/src/cfg_run.ml
@@ -7,52 +7,81 @@ open Cfg
open Utils
open Builtins
-let rec eval_cfgexpr st (e: expr) : int res =
+let rec eval_cfgexpr oc st cp (e: expr) : (int * int state) res =
match e with
| Ebinop(b, e1, e2) ->
- eval_cfgexpr st e1 >>= fun v1 ->
- eval_cfgexpr st e2 >>= fun v2 ->
+ eval_cfgexpr oc st cp e1 >>= fun (v1, st') ->
+ eval_cfgexpr oc st' cp e2 >>= fun (v2, st'') ->
let v = eval_binop b v1 v2 in
- OK v
+ OK (v, st'')
| Eunop(u, e) ->
- eval_cfgexpr st e >>= fun v1 ->
+ eval_cfgexpr oc st cp e >>= fun (v1, st') ->
let v = (eval_unop u v1) in
- OK v
- | Eint i -> OK i
+ OK (v, st')
+ | Eint i -> OK (i, st)
| Evar s ->
begin match Hashtbl.find_option st.env s with
- | Some v -> OK v
+ | Some v -> OK (v, st)
| None -> Error (Printf.sprintf "Unknown variable %s\n" s)
end
-
-let rec eval_cfginstr oc st ht (n: int): (int * int state) res =
+ | Ecall (f, args) ->
+ List.fold_left (
+ fun (acc : (int list * int state) res) (arg : expr) ->
+ match acc with
+ | Error msg -> Error msg
+ | OK (l, st') ->
+ match eval_cfgexpr oc st' cp arg with
+ | Error msg -> Error msg
+ | OK (i, st'') -> OK ((l@[i]), st'')
+ ) (OK([], st)) args >>= fun (int_args, st') ->
+ find_function cp f >>= fun found_f ->
+ match eval_cfgfun oc st' cp f found_f int_args with
+ | Error msg -> Error msg
+ | OK (None, st'') -> Error (Format.sprintf "CFG: Function %s doesn't have a return value.\n" f)
+ | OK (Some ret, st'') -> OK (ret, st'')
+
+and eval_cfginstr oc st cp ht (n: int): (int * int state) res =
match Hashtbl.find_option ht n with
| None -> Error (Printf.sprintf "Invalid node identifier\n")
| Some node ->
match node with
| Cnop succ ->
- eval_cfginstr oc st ht succ
+ eval_cfginstr oc st cp ht succ
| Cassign(v, e, succ) ->
- eval_cfgexpr st e >>= fun i ->
- Hashtbl.replace st.env v i;
- eval_cfginstr oc st ht succ
+ eval_cfgexpr oc st cp e >>= fun (i, st') ->
+ Hashtbl.replace st'.env v i;
+ eval_cfginstr oc st' cp ht succ
| Ccmp(cond, i1, i2) ->
- eval_cfgexpr st cond >>= fun i ->
- if i = 0 then eval_cfginstr oc st ht i2 else eval_cfginstr oc st ht i1
+ eval_cfgexpr oc st cp cond >>= fun (i, st') ->
+ if i = 0 then eval_cfginstr oc st' cp ht i2 else eval_cfginstr oc st' cp ht i1
| Creturn(e) ->
- eval_cfgexpr st e >>= fun e ->
- OK (e, st)
+ eval_cfgexpr oc st cp e >>= fun (e, st') ->
+ OK (e, st')
| Cprint(e, succ) ->
- eval_cfgexpr st e >>= fun e ->
+ eval_cfgexpr oc st cp e >>= fun (e, st') ->
Format.fprintf oc "%d\n" e;
- eval_cfginstr oc st ht succ
+ eval_cfginstr oc st' cp ht succ
+ | Ccall (f, args, succ) ->
+ List.fold_left (
+ fun (acc : (int list * int state) res) (arg : expr) ->
+ match acc with
+ | Error msg -> Error msg
+ | OK (l, st') ->
+ match eval_cfgexpr oc st' cp arg with
+ | Error msg -> Error msg
+ | OK (i, st'') -> OK ((l@[i]), st'')
+ ) (OK([], st)) args
+ >>= fun (int_args, st') ->
+ find_function cp f >>= fun found_f ->
+ eval_cfgfun oc st' cp f found_f int_args >>= fun (ret, st'') ->
+ eval_cfginstr oc st'' cp ht succ
-let eval_cfgfun oc st cfgfunname { cfgfunargs;
+and eval_cfgfun oc st cp cfgfunname { cfgfunargs;
cfgfunbody;
cfgentry} vargs =
let st' = { st with env = Hashtbl.create 17 } in
match List.iter2 (fun a v -> Hashtbl.replace st'.env a v) cfgfunargs vargs with
- | () -> eval_cfginstr oc st' cfgfunbody cfgentry >>= fun (v, st') ->
+ | () -> eval_cfginstr oc st' cp cfgfunbody cfgentry >>= fun (v, st') ->
OK (Some v, {st' with env = st.env})
| exception Invalid_argument _ ->
Error (Format.sprintf "CFG: Called function %s with %d arguments, expected %d.\n"
@@ -64,7 +93,7 @@ let eval_cfgprog oc cp memsize params =
find_function cp "main" >>= fun f ->
let n = List.length f.cfgfunargs in
let params = take n params in
- eval_cfgfun oc st "main" f params >>= fun (v, st) ->
+ eval_cfgfun oc st cp "main" f params >>= fun (v, st) ->
OK v
diff --git a/src/elang_run.ml b/src/elang_run.ml
index e4509f6..880e938 100644
--- a/src/elang_run.ml
+++ b/src/elang_run.ml
@@ -100,7 +100,7 @@ and eval_einstr oc (st: int state) (ep: eprog) (ins: instr) :
| Iif (e, i1, i2) ->
(match eval_eexpr oc st ep e with
| Error msg -> Error msg
- | OK (v, st') -> if v = 1 then eval_einstr oc st' ep i1 else eval_einstr oc st' ep i2)
+ | OK (v, st') -> if v = 0 then eval_einstr oc st' ep i2 else eval_einstr oc st' ep i1)
| Iwhile (e, i) ->
(match eval_eexpr oc st ep e with
| Error msg -> Error msg
--
GitLab
From beadabee7b1c9875ba69142758bf44ad3ce41555 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Sat, 15 Mar 2025 11:10:55 +0100
Subject: [PATCH 10/11] functions : RTL
---
src/linear_gen.ml | 24 ++++++++++++------------
src/rtl.ml | 5 +++++
src/rtl_gen.ml | 18 +++++++++++++++++-
src/rtl_print.ml | 4 ++++
src/rtl_run.ml | 19 +++++++++++++++++++
5 files changed, 57 insertions(+), 13 deletions(-)
diff --git a/src/linear_gen.ml b/src/linear_gen.ml
index cd83deb..f6a6d14 100644
--- a/src/linear_gen.ml
+++ b/src/linear_gen.ml
@@ -8,6 +8,8 @@ open Linear_print
open Options
open Linear_liveness
+type 'a set = 'a Set.t
+
let succs_of_rtl_instr (i: rtl_instr) =
match i with
| Rtl.Rbranch (_, _, _, s1) -> [s1]
@@ -19,41 +21,39 @@ let rec succs_of_rtl_instrs il : int list =
(* effectue un tri topologique des blocs. *)
let sort_blocks (nodes: (int, rtl_instr list) Hashtbl.t) entry =
- let rec add_block order visited n =
+ let rec add_block order visited n : reg list * reg set =
(* TODO *)
- List.of_enum (Hashtbl.keys nodes)
- (*if Set.mem n visited
- then order
+ (*List.of_enum (Hashtbl.keys nodes)*)
+ if Set.mem n visited
+ then order, visited
else let succs = succs_of_rtl_instrs (Hashtbl.find nodes n)
- in List.concat( (order@[n]) :: List.map (add_block [] (Set.add n visited)) succs )*)
+ in List.fold_left (fun (ord, vis) s -> add_block ord vis s) (order@[n], Set.add n visited) succs
in
- add_block [] Set.empty entry
+ fst (add_block [] Set.empty entry)
(* Supprime les jumps inutiles (Jmp à un label défini juste en dessous). *)
let rec remove_useless_jumps (l: rtl_instr list) =
(* TODO *)
- l
- (*match l with
+ match l with
| [] -> []
| Rjmp l1::Rlabel l2::rest ->
if l1=l2
then Rlabel l2::remove_useless_jumps rest
else Rjmp l1::Rlabel l2::remove_useless_jumps rest
- | i::rest -> i::remove_useless_jumps rest*)
+ | i::rest -> i::remove_useless_jumps rest
(* Remove labels that are never jumped to. *)
let remove_useless_labels (l: rtl_instr list) =
(* TODO *)
- l
- (*List.filter (function
+ List.filter (function
Rlabel i -> List.exists (
function
Rbranch(_, _, _, j) -> j = i
| Rjmp j -> j = i
| _ -> false) l
- | _ -> true) l*)
+ | _ -> true) l
let linear_of_rtl_fun
({ rtlfunargs; rtlfunbody; rtlfunentry; rtlfuninfo }: rtl_fun) =
diff --git a/src/rtl.ml b/src/rtl.ml
index ab703a0..0360732 100644
--- a/src/rtl.ml
+++ b/src/rtl.ml
@@ -15,6 +15,7 @@ type rtl_instr = Rbinop of binop * reg * reg * reg
| Rret of reg
| Rlabel of int
| Rprint of reg
+ | Rcall of reg option * string * reg list
type rtl_fun = { rtlfunargs: reg list;
rtlfunbody: (int, rtl_instr list) Hashtbl.t;
@@ -33,6 +34,10 @@ let written_rtl_regs_instr (i: rtl_instr) =
| Rlabel _
| Rbranch (_, _, _, _)
| Rjmp _ -> Set.empty
+ | Rcall (rd_opt, _, _) ->
+ match rd_opt with
+ | None -> Set.empty
+ | Some rd -> Set.singleton rd
let written_rtl_regs (l: rtl_instr list) =
List.fold_left (fun acc i -> Set.union acc (written_rtl_regs_instr i))
diff --git a/src/rtl_gen.ml b/src/rtl_gen.ml
index 7955b3f..e49d304 100644
--- a/src/rtl_gen.ml
+++ b/src/rtl_gen.ml
@@ -53,6 +53,14 @@ let rec rtl_instrs_of_cfg_expr (next_reg, var2reg) (e: expr) =
| Eunop (u, e) ->
let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) e
in (next_reg', l@[Runop(u, next_reg', r)], next_reg'+1, var2reg')
+ | Ecall (f, args) ->
+ let regs, l, next_reg', var2reg' =
+ List.fold_left
+ (fun (regs, instrs, next_reg, var2reg) arg ->
+ let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) arg
+ in (regs@[r], instrs@l, next_reg', var2reg'))
+ ([], [], next_reg, var2reg) args
+ in (next_reg', l@[Rcall (Some next_reg', f, regs)], next_reg' + 1, var2reg')
let is_cmp_op =
function Eclt -> Some Rclt
@@ -89,8 +97,16 @@ let rtl_instrs_of_cfg_node ((next_reg:int), (var2reg: (string*int) list)) (c: cf
let cmp, e1, e2 = rtl_cmp_of_cfg_expr e
in let r1, l1, next_reg1, var2reg1 = rtl_instrs_of_cfg_expr (next_reg, var2reg) e1
in let r2, l2, next_reg2, var2reg2 = rtl_instrs_of_cfg_expr (next_reg1, var2reg1) e2
- in (l1@l2@[Rbranch(cmp, r1, r2, i1)]@[Rjmp i2], next_reg2, var2reg2)
+ in (l1@l2@[Rbranch(cmp, r1, r2, i1); Rjmp i2], next_reg2, var2reg2)
| Cnop i -> ([Rjmp i], next_reg, var2reg)
+ | Ccall (f, args, i) ->
+ let regs, l, next_reg', var2reg' =
+ List.fold_left
+ (fun (regs, instrs, next_reg, var2reg) arg ->
+ let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) arg
+ in (regs@[r], instrs@l, next_reg', var2reg'))
+ ([], [], next_reg, var2reg) args
+ in (l@[Rcall (None, f, regs); Rjmp i], next_reg', var2reg')
let rtl_instrs_of_cfg_fun cfgfunname ({ cfgfunargs; cfgfunbody; cfgentry }: cfg_fun) =
let (rargs, next_reg, var2reg) =
diff --git a/src/rtl_print.ml b/src/rtl_print.ml
index f0b4734..a9c1224 100644
--- a/src/rtl_print.ml
+++ b/src/rtl_print.ml
@@ -41,6 +41,10 @@ let dump_rtl_instr name (live_in, live_out) ?(endl="\n") oc (i: rtl_instr) =
| Rret r -> Format.fprintf oc "ret %s" (print_reg r)
| Rprint r -> Format.fprintf oc "print %s" (print_reg r)
| Rlabel n -> Format.fprintf oc "%s_%d:" name n
+ | Rcall (rd_opt, f, regs) ->
+ match rd_opt with
+ | None -> Format.fprintf oc "call %s with args : %s" f (String.concat ", " (List.map print_reg regs))
+ | Some rd -> Format.fprintf oc "%s <- call %s with args : %s" (print_reg rd) f (String.concat ", " (List.map print_reg regs))
end;
Format.fprintf oc "%s" endl;
dump_liveness live_out "after"
diff --git a/src/rtl_run.ml b/src/rtl_run.ml
index f8dcde8..fb7a809 100644
--- a/src/rtl_run.ml
+++ b/src/rtl_run.ml
@@ -77,6 +77,25 @@ let rec exec_rtl_instr oc rp rtlfunname f st (i: rtl_instr) =
| _ -> Error (Printf.sprintf "Print on undefined register (%s)" (print_reg r))
end
| Rlabel n -> OK (None, st)
+ | Rcall (rd_opt, g, args) ->
+ begin
+ let vs_opt = List.fold_left (fun acc arg ->
+ match acc with
+ | None -> None
+ | Some vs ->
+ (match Hashtbl.find_option st.regs arg with
+ | None -> None
+ | Some v -> Some (vs@[v])))
+ (Some []) args
+ in match vs_opt with
+ | Some params -> find_function rp g >>= fun found_g ->
+ (match rd_opt, exec_rtl_fun oc rp st g found_g params with
+ | _, Error msg -> Error msg
+ | Some rd, OK (Some ret, st') -> exec_rtl_instr oc rp rtlfunname f st' (Rconst (rd, ret))
+ | Some rd, OK (None, st') -> Error (Printf.sprintf "Function %s doesn't have a return value" g)
+ | None, OK (_, st') -> OK(None, st'))
+ | _ -> Error (Printf.sprintf "Function %s applied on undefined register" g)
+ end
and exec_rtl_instr_at oc rp rtlfunname ({ rtlfunbody; } as f: rtl_fun) st i =
match Hashtbl.find_option rtlfunbody i with
--
GitLab
From 9e90172e13ff96b84f11c6b023e7493b5d846274 Mon Sep 17 00:00:00 2001
From: Youssef <youssef.sellami@student-cs.fr>
Date: Sun, 16 Mar 2025 15:30:37 +0100
Subject: [PATCH 11/11] functions : LTL
---
src/linear_liveness.ml | 7 +++++--
src/linear_run.ml | 19 +++++++++++++++++++
src/ltl_gen.ml | 35 ++++++++++++++++++++++++++++++-----
3 files changed, 54 insertions(+), 7 deletions(-)
diff --git a/src/linear_liveness.ml b/src/linear_liveness.ml
index 0a5891e..5082e7f 100644
--- a/src/linear_liveness.ml
+++ b/src/linear_liveness.ml
@@ -16,18 +16,21 @@ let gen_live (i: rtl_instr) =
| Rmov (_, rs) -> Set.singleton rs
| Rret r -> Set.singleton r
| Rlabel _ -> Set.empty
+ | Rcall (_, _, args) -> Set.of_list args
let kill_live (i: rtl_instr) =
match i with
| Rbinop (_, rd, _, _)
| Runop (_, rd,_)
| Rconst (rd, _)
- | Rmov (rd,_) -> Set.singleton rd
+ | Rmov (rd,_)
+ | Rcall (Some rd, _, _) -> Set.singleton rd
| Rbranch (_, _, _, _)
| Rprint _
| Rret _
| Rjmp _
- | Rlabel _ -> Set.empty
+ | Rlabel _
+ | Rcall (None, _, _) -> Set.empty
let linear_succs (ins: rtl_instr) i labels =
match ins with
diff --git a/src/linear_run.ml b/src/linear_run.ml
index 63b622a..8051790 100644
--- a/src/linear_run.ml
+++ b/src/linear_run.ml
@@ -60,6 +60,25 @@ let rec exec_linear_instr oc lp fname f st (i: rtl_instr) =
| _ -> Error (Printf.sprintf "Ret on undefined register (%s)" (print_reg r))
end
| Rlabel n -> OK (None, st)
+ | Rcall (rd_opt, g, args) ->
+ begin
+ let vs_opt = List.fold_left (fun acc arg ->
+ match acc with
+ | None -> None
+ | Some vs ->
+ (match Hashtbl.find_option st.regs arg with
+ | None -> None
+ | Some v -> Some (vs@[v])))
+ (Some []) args
+ in match vs_opt with
+ | Some params -> find_function lp g >>= fun found_g ->
+ (match rd_opt, exec_linear_fun oc lp st g found_g params with
+ | _, Error msg -> Error msg
+ | Some rd, OK (Some ret, st') -> exec_linear_instr oc lp fname f st' (Rconst (rd, ret))
+ | Some rd, OK (None, st') -> Error (Printf.sprintf "Function %s doesn't have a return value" g)
+ | None, OK (_, st') -> OK(None, st'))
+ | _ -> Error (Printf.sprintf "Function %s applied on undefined register" g)
+ end
and exec_linear_instr_at oc lp fname ({ linearfunbody; } as f) st i =
let l = List.drop_while (fun x -> x <> Rlabel i) linearfunbody in
diff --git a/src/ltl_gen.ml b/src/ltl_gen.ml
index aa6a9fa..581f0c9 100644
--- a/src/ltl_gen.ml
+++ b/src/ltl_gen.ml
@@ -51,7 +51,7 @@ let make_loc_mov src dst =
[LMov(rdst,rsrc)]
(* load_loc tmp allocation r = (l, r'). Loads the equivalent of RTL register r
- in a LTL register r'. tmpis used if necessary. *)
+ in a LTL register r'. tmp is used if necessary. *)
let load_loc tmp allocation r =
match Hashtbl.find_option allocation r with
| None ->
@@ -215,26 +215,27 @@ let written_rtl_regs_instr (i: rtl_instr) =
| Rbinop (_, rd, _, _)
| Runop (_, rd, _)
| Rconst (rd, _)
- | Rmov (rd, _) -> Set.singleton rd
+ | Rmov (rd, _)
+ | Rcall (Some rd, _, _)-> Set.singleton rd
| Rprint _
| Rret _
| Rlabel _
| Rbranch (_, _, _, _)
- | Rjmp _ -> Set.empty
+ | Rjmp _
+ | Rcall (None, _, _) -> Set.empty
let read_rtl_regs_instr (i: rtl_instr) =
match i with
| Rbinop (_, _, rs1, rs2)
| Rbranch (_, rs1, rs2, _) -> Set.of_list [rs1; rs2]
-
| Rprint rs
| Runop (_, _, rs)
| Rmov (_, rs)
| Rret rs -> Set.singleton rs
-
| Rlabel _
| Rconst (_, _)
| Rjmp _ -> Set.empty
+ | Rcall (_, _, args) -> Set.of_list args
let read_rtl_regs (l: rtl_instr list) =
List.fold_left (fun acc i -> Set.union acc (read_rtl_regs_instr i))
@@ -323,6 +324,30 @@ let ltl_instrs_of_linear_instr fname live_out allocation
load_loc reg_tmp1 allocation r >>= fun (l,r) ->
OK (l @ [LMov (reg_ret, r) ; LJmp epilogue_label])
| Rlabel l -> OK [LLabel (Format.sprintf "%s_%d" fname l)]
+
+ | Rcall (rd_opt, f, rargs) ->
+ caller_save live_out allocation rargs >>= fun to_save ->
+ let save_regs_instrs, arg_saved, ofs = save_caller_save (Set.to_list to_save) (-(numspilled + 1))
+ in let move_sp_instr1 = LSubi(reg_sp, reg_s0, (Archi.wordsize ()) * -(ofs + 1))
+ in pass_parameters rargs allocation arg_saved >>= fun (parameter_passing_instrs, npush) ->
+ let call_instr = LCall f
+ in let move_sp_instr2 = LAddi(reg_sp, reg_sp, (Archi.wordsize ()) * npush)
+ in let return_instrs_and_reg = match rd_opt with
+ | None -> OK ([], None)
+ | Some rd ->
+ match Hashtbl.find_option allocation rd with
+ | None -> Error (Format.sprintf "Could not find allocation for register %d\n" rd)
+ | Some (Stk o) -> OK (make_loc_mov (Reg reg_ret) (Stk o) , None)
+ | Some (Reg r_phy) -> OK (make_loc_mov (Reg reg_ret) (Reg r_phy), Some r_phy)
+ in return_instrs_and_reg >>= fun (return_instrs, r_ret_opt) ->
+ let arg_saved_wout_rd = List.filter (fun (reg, stk_loc) -> match r_ret_opt with | None -> true | Some r_ret -> reg != r_ret) arg_saved
+ in let restore_caller_save_instrs = restore_caller_save arg_saved_wout_rd
+ in let move_sp_instr3 = LAddi(reg_sp, reg_sp, (Archi.wordsize ()) * -(ofs + 1))
+ in OK (save_regs_instrs
+ @ move_sp_instr1 :: parameter_passing_instrs
+ @ call_instr :: move_sp_instr2 :: return_instrs
+ @ restore_caller_save_instrs
+ @ [move_sp_instr3])
in
res >>= fun l ->
OK (LComment (Format.asprintf "#<span style=\"background: pink;\"><b>Linear instr</b>: %a #</span>" (Rtl_print.dump_rtl_instr fname (None, None) ~endl:"") ins)::l)
--
GitLab