diff --git a/ecomp b/ecomp
new file mode 120000
index 0000000000000000000000000000000000000000..b09fe7bf4650098ca4848ba087e8468e4877e6f8
--- /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 9ab7ecd32a798aa929d04416aa9706f289d1ce20..b8715788a735dc6305cdbe0404771acc8d6d22f5 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,13 +23,94 @@ axiom S
open Batteries
open Utils
+ type after_id =
+ | Assign of tree
+ | Funcall of tree list
+ | Nothing
+
(* 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, $1) }
+FUNDEFS -> FUNDEF FUNDEFS { $1::$2 }
+FUNDEFS -> { [] }
+FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { Node(Tfundef, [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$5])]) }
+LPARAMS -> IDENTIFIER REST_PARAMS { Node(Targ, [$1])::$2 }
+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 }
+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 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 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 }
-rules
-S -> FUNDEFS SYM_EOF { Node (Tlistglobdef, []) }
+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 }
+
+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 }
+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 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}
+INTEGER -> SYM_INTEGER {IntLeaf $1}
diff --git a/src/ast.ml b/src/ast.ml
index bfd93a8a25c70dd90d9f6504fa19e221ed3bb193..cfb67d68813386c3ef6d396f5c9edec01f3753bc 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/cfg.ml b/src/cfg.ml
index 7c4cb023ce56fa2c68501c5b9369ec311c7996cc..2a60c97dde93858dca8cb0acd4d788686e407ad4 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_dead_assign.ml b/src/cfg_dead_assign.ml
index e35fc4762eb958bb4ec5ad1be98fbbb409a6e39e..00c2b5bee24c28912196ed351a6927875d07e57e 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_gen.ml b/src/cfg_gen.ml
index 18509ef62dd1711bdfe41db26dfd56fe3e5676f5..ff2aa1b40a58fd120993c33ea76d81ad62566d50 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 194a291e76ca270951a3b881023f504b3355174e..aa402063e865558f9d0cbc79c32717de5f4e4789 100644
--- a/src/cfg_liveness.ml
+++ b/src/cfg_liveness.ml
@@ -1,12 +1,18 @@
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
+ | 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,
@@ -14,14 +20,27 @@ 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
+ | Ccall (f, args, i) -> vars_in_expr (Ecall (f, args))
+ 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 +50,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 da45a5a8656f295bd0f6dc9cdab2d9101d5554d0..dba2b517d3bd5a6eae86084e13ba3f83bfa0f2e2 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,21 @@ 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)
+ | Cnop i -> Cnop (replace_succ nop_succs i)
+ | 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) =
@@ -67,13 +81,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 *)
- Some 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
diff --git a/src/cfg_print.ml b/src/cfg_print.ml
index 6ec810a6254e741900bea58fd5954da1e5f8062a..a4524107bb648e3821eb41279a3878c7d92e1212 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 6557acdb2f0ad6996e7b33f2a469536df24118c8..e2e421204f922d190bce803195f29afe19b47f36 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/e_regexp.ml b/src/e_regexp.ml
index bbc5b204ba11e4fcba87a032c342ff699b2719e6..a87413d6fb052bca56730881cba0e5c388752812 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/elang.ml b/src/elang.ml
index 72b8e18b5c4a94b0226063a502ed274af1822d59..38b4f66064e4cedae6f4f8478ce1cae41b379c9a 100644
--- a/src/elang.ml
+++ b/src/elang.ml
@@ -9,6 +9,7 @@ type expr =
| 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 be904b1e67d18e2c0f25d8896b1610cc1dbe287e..1d4db2d1429c325bdedeeedad12cb9ea8b081995 100644
--- a/src/elang_gen.ml
+++ b/src/elang_gen.ml
@@ -44,10 +44,28 @@ 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)))
+ | 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))
in
match res with
@@ -59,6 +77,48 @@ 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)
+ | 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))
in
@@ -76,10 +136,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_print.ml b/src/elang_print.ml
index 2da36d9e99f479b155b024d2cb9aefd56247c39e..8f7f8cf490c74b16488a4730058296cb8c9cd402 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 494b2c6ac0da84d327a4e1016b7da8f57b3ae57e..880e93885acae46e84b0c19c54227c195cc7bd4d 100644
--- a/src/elang_run.ml
+++ b/src/elang_run.ml
@@ -9,18 +9,70 @@ 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."
-
+let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
+ match e with
+ | Eint i -> OK (i, st)
+ | Evar s ->
+ (match Hashtbl.find_option st.env s with
+ | Some i -> OK (i, st)
+ | None -> Error "Variable is not defined")
+ | Ebinop (b, ex, ey) ->
+ (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 oc st ep ex
+ in match res_x with
+ | Error msg -> Error msg
+ | 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"
@@ -33,16 +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 =
- Error "eval_einstr not implemented yet."
+ match ins with
+ | Iassign (s, e) ->
+ (match eval_eexpr oc st ep e with
+ | Error msg -> Error msg
+ | 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))
+ | Iif (e, i1, i2) ->
+ (match eval_eexpr oc st ep e with
+ | Error msg -> Error msg
+ | 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
+ | 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 ep (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 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 ep (Iblock rest))
+ | Ireturn e ->
+ (match eval_eexpr oc st ep e with
+ | Error msg -> Error msg
+ | OK (v, st') -> OK(Some v, st'))
+ | Iprint e ->
+ (match eval_eexpr oc st ep e with
+ | Error msg -> Error msg
+ | OK (v, st') ->
+ Format.fprintf oc "%d\n" v;
+ 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
@@ -54,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
@@ -85,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/lexer_generator.ml b/src/lexer_generator.ml
index 06192ef87ea5c27187c59a50121930bdc00ec905..e75d1eef76c6f109166d380d2c7794f9590d10d5 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/linear_gen.ml b/src/linear_gen.ml
index c12bd04588cfef6a06de11d299bd2ebcd26c09c3..f6a6d14c94e6c7b28583eda634837bf9f4fd1baa 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,23 +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 n =
- (* TODO *)
- List.of_enum (Hashtbl.keys nodes)
+ 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, visited
+ else let succs = succs_of_rtl_instrs (Hashtbl.find nodes n)
+ in List.fold_left (fun (ord, vis) s -> add_block ord vis s) (order@[n], Set.add n visited) succs
in
- add_block [] 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
+ (* TODO *)
+ 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 *)
+ 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/linear_liveness.ml b/src/linear_liveness.ml
index 0a5891e75cfe8718612141f84e5e97e86f8b377c..5082e7fe9b9cf1460e1b2cf92889f7c7297d94f5 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 63b622a56408dea0d4fe1c4c2d84cc875e319da7..80517908cb8721c7501ca4e4d8056b7b89d87251 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 aa6a9fa16cc866bdcb76848577ada490f3b5ae22..581f0c9b64f3710f3048ed905e62f31a5a1a1e9a 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)
diff --git a/src/regalloc.ml b/src/regalloc.ml
index c68b9fdcb599dfb74185b339459873603ebc8e42..897da01f9abcdcbd1927beb5164078808f464ea6 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,8 +90,9 @@ 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
variables à la sortie des nœuds donné par [live_out].
@@ -120,9 +122,9 @@ 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 *)
+ 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.
@@ -159,8 +161,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 +173,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 +226,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.ml b/src/rtl.ml
index ab703a052a576fcb000cc3eb1ed68a08653d225b..0360732db82bb6f335507b3ad392dba7e3ff7326 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 ce1eb8f84ef214052bb074b76658d460ac7045df..e49d304f4b9e73e7859a18212522e75e1a542809 100644
--- a/src/rtl_gen.ml
+++ b/src/rtl_gen.ml
@@ -43,7 +43,24 @@ 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')
+ | 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
@@ -64,8 +81,32 @@ 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)
+ | 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 f0b473438d9927b2ae15de2daf7975c48bb44a20..a9c1224e8920af8ab16733a816846d794f1f02dc 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 f8dcde8b45e374eac882af10c37d6be30e2adc29..fb7a809f37c47f6bbaaa824117bffa843e4826d8 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
diff --git a/src/test_lexer.ml b/src/test_lexer.ml
index 72ffda45d229eb9ab198c2de6c5e57ffd349eb2b..40c9f8ea5c0b89303f505c228cb3233f127725ea 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/Makefile b/tests/Makefile
index 7f5a992327ddebee63e223a3f3eda7070950bfbf..ef3fa0a92cb0f08481c60752b7797db738cd6921 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/basic/just_a_variable_37.e b/tests/basic/just_a_variable_37.e
index 51add73273ef1612c1b90276c8ad3b7fc7129f0f..3551b563b8a191ab30b62ceb8e3e3fe0ecf71c31 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;
}
diff --git a/tests/funcall/argswap.e.expect_lexer b/tests/funcall/argswap.e.expect_lexer
index 2c8a87dc1d273f5d6156be905b62504276797c7b..89b98c324fdb2b227f987c44d6cd1bba0c75859d 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 834218f66d791aed054dec525bb4e0e33596260b..d8e49347bfd160352797416d6be13177edbc3ee4 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