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] 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