Commit c6e03578 authored by Armillon Damien's avatar Armillon Damien
Browse files

Function call to cfg

parent 8c2b101f
...@@ -26,3 +26,6 @@ clean: ...@@ -26,3 +26,6 @@ clean:
test: main.native test: main.native
make -C tests make -C tests
testFun: main.native
make -C tests DIR=funcall/*.e
\ No newline at end of file
...@@ -11,6 +11,7 @@ non-terminals MUL_EXPRS MUL_EXPR ...@@ -11,6 +11,7 @@ non-terminals MUL_EXPRS MUL_EXPR
non-terminals CMP_EXPRS CMP_EXPR non-terminals CMP_EXPRS CMP_EXPR
non-terminals EQ_EXPRS EQ_EXPR non-terminals EQ_EXPRS EQ_EXPR
non-terminals BLOC non-terminals BLOC
non-terminals IN_INSTR L_CALL_PARAMS REST_CALL_PARAMS FACTORS FUN_CALL_EXPRS FUN_CALL_EXPR FACTOR_IDENTIFIER
axiom S axiom S
{ {
...@@ -37,14 +38,20 @@ LPARAMS -> {[]} ...@@ -37,14 +38,20 @@ LPARAMS -> {[]}
LPARAMS -> SYM_IDENTIFIER REST_PARAMS {(Node(Targ, [StringLeaf($1)])) :: $2} LPARAMS -> SYM_IDENTIFIER REST_PARAMS {(Node(Targ, [StringLeaf($1)])) :: $2}
REST_PARAMS -> SYM_COMMA SYM_IDENTIFIER REST_PARAMS {(Node(Targ, [StringLeaf($2)])):: $3} REST_PARAMS -> SYM_COMMA SYM_IDENTIFIER REST_PARAMS {(Node(Targ, [StringLeaf($2)])):: $3}
REST_PARAMS -> {[]} REST_PARAMS -> {[]}
L_CALL_PARAMS -> {[]}
L_CALL_PARAMS -> EXPR REST_CALL_PARAMS {[Node(Targs, $1::$2)]}
REST_CALL_PARAMS -> {[]}
REST_CALL_PARAMS -> SYM_COMMA EXPR REST_CALL_PARAMS {$2::$3}
IN_INSTR -> SYM_LPARENTHESIS L_CALL_PARAMS SYM_RPARENTHESIS SYM_SEMICOLON {fun x -> Node(Tcall, (StringLeaf x)::$2)}
IN_INSTR -> SYM_ASSIGN EXPR SYM_SEMICOLON {fun x -> Node(Tassign, [Node(Tassignvar,[StringLeaf(x); $2])])}
INSTRS -> {[]} INSTRS -> {[]}
INSTRS -> INSTR INSTRS {$1::$2} INSTRS -> INSTR INSTRS {$1::$2}
INSTR -> BLOC {$1} INSTR -> BLOC {$1}
INSTR -> SYM_IDENTIFIER IN_INSTR {$2 $1}
INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC ELSE {Node(Tif, $3::$5::$6)} INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC ELSE {Node(Tif, $3::$5::$6)}
INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC {Node(Twhile, [$3;$5])} INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC {Node(Twhile, [$3;$5])}
INSTR -> SYM_RETURN EXPR SYM_SEMICOLON {Node(Treturn, [$2])} INSTR -> SYM_RETURN EXPR SYM_SEMICOLON {Node(Treturn, [$2])}
INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON {Node(Tprint, [$3])} INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON {Node(Tprint, [$3])}
INSTR -> SYM_IDENTIFIER SYM_ASSIGN EXPR SYM_SEMICOLON {Node(Tassign, [Node(Tassignvar,[StringLeaf($1);$3])])}
ELSE -> SYM_ELSE BLOC {[$2]} ELSE -> SYM_ELSE BLOC {[$2]}
ELSE -> {[]} ELSE -> {[]}
EXPR -> EQ_EXPR EQ_EXPRS {resolve_associativity $1 $2} EXPR -> EQ_EXPR EQ_EXPRS {resolve_associativity $1 $2}
...@@ -66,8 +73,14 @@ MUL_EXPRS -> SYM_ASTERISK MUL_EXPR MUL_EXPRS {(Tmul, [$2])::$3} ...@@ -66,8 +73,14 @@ 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_DIV MUL_EXPR MUL_EXPRS {(Tdiv, [$2])::$3}
MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS {(Tmod, [$2])::$3} MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS {(Tmod, [$2])::$3}
MUL_EXPRS -> {[]} MUL_EXPRS -> {[]}
MUL_EXPR -> FACTOR {$1} MUL_EXPR -> FACTORS { $1 }
MUL_EXPR -> SYM_MINUS FACTOR {Node(Tneg,[$2])} FUN_CALL_EXPRS -> SYM_IDENTIFIER SYM_LPARENTHESIS SYM_RPARENTHESIS {[(Tcall,[])]}
FUN_CALL_EXPRS -> {[]}
FUN_CALL_EXPR -> FACTORS {$1}
FACTORS -> FACTOR {$1}
FACTORS -> SYM_MINUS FACTOR {Node(Tneg,[$2])}
FACTOR_IDENTIFIER -> {fun x -> StringLeaf(x)}
FACTOR_IDENTIFIER -> SYM_LPARENTHESIS L_CALL_PARAMS SYM_RPARENTHESIS {fun x -> Node(Tcall, (StringLeaf x)::$2)}
FACTOR -> SYM_INTEGER {Node(Tint,[IntLeaf($1)])} FACTOR -> SYM_INTEGER {Node(Tint,[IntLeaf($1)])}
FACTOR -> SYM_IDENTIFIER {StringLeaf($1)} FACTOR -> SYM_IDENTIFIER FACTOR_IDENTIFIER {$2 $1}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS {$2} FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS {$2}
...@@ -31,7 +31,7 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint ...@@ -31,7 +31,7 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint
| Tlistglobdef | Tlistglobdef
| Tfundef | Tfunname | Tfunargs | Tfunbody | Tfundef | Tfunname | Tfunargs | Tfunbody
| Tassignvar | Tassignvar
| Targ | Targ | Tcall | Targs
type tree = | Node of tag * tree list type tree = | Node of tag * tree list
| StringLeaf of string | StringLeaf of string
...@@ -74,6 +74,8 @@ let string_of_tag = function ...@@ -74,6 +74,8 @@ let string_of_tag = function
| Tfunbody -> "Tfunbody" | Tfunbody -> "Tfunbody"
| Tassignvar -> "Tassignvar" | Tassignvar -> "Tassignvar"
| Targ -> "Targ" | Targ -> "Targ"
| Tcall -> "Tcall"
| Targs -> "Targs"
(* Écrit un fichier .dot qui correspond à un AST *) (* Écrit un fichier .dot qui correspond à un AST *)
......
...@@ -9,6 +9,7 @@ type expr = ...@@ -9,6 +9,7 @@ type expr =
| Eunop of unop * expr | Eunop of unop * expr
| Eint of int | Eint of int
| Evar of string | Evar of string
| Ecall of string * expr list
type cfg_node = type cfg_node =
| Cassign of string * expr * int | Cassign of string * expr * int
...@@ -16,6 +17,7 @@ type cfg_node = ...@@ -16,6 +17,7 @@ type cfg_node =
| Cprint of expr * int | Cprint of expr * int
| Ccmp of expr * int * int | Ccmp of expr * int * int
| Cnop of int | Cnop of int
| Ccall of string * expr list * int
type cfg_fun = { type cfg_fun = {
cfgfunargs: string list; cfgfunargs: string list;
...@@ -36,6 +38,7 @@ let succs cfg n = ...@@ -36,6 +38,7 @@ let succs cfg n =
| Some (Creturn _) -> Set.empty | Some (Creturn _) -> Set.empty
| Some (Ccmp (_, s1, s2)) -> Set.of_list [s1;s2] | Some (Ccmp (_, s1, s2)) -> Set.of_list [s1;s2]
| Some (Cnop s) -> Set.singleton s | 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] (* [preds cfg n] donne l'ensemble des prédécesseurs d'un nœud [n] dans un CFG [cfg]
...@@ -45,6 +48,7 @@ let preds cfgfunbody n = ...@@ -45,6 +48,7 @@ let preds cfgfunbody n =
match m' with match m' with
| Cassign (_, _, s) | Cassign (_, _, s)
| Cprint (_, s) | Cprint (_, s)
| Ccall (_,_,s)
| Cnop s -> if s = n then Set.add m acc else acc | Cnop s -> if s = n then Set.add m acc else acc
| Creturn _ -> acc | Creturn _ -> acc
| Ccmp (_, s1, s2) -> if s1 = n || s2 = n then Set.add m acc else acc | Ccmp (_, s1, s2) -> if s1 = n || s2 = n then Set.add m acc else acc
...@@ -63,6 +67,7 @@ let rec size_expr (e: expr) : int = ...@@ -63,6 +67,7 @@ let rec size_expr (e: expr) : int =
| Eunop (u, e) -> size_unop u (size_expr e) | Eunop (u, e) -> size_unop u (size_expr e)
| Eint _ -> 1 | Eint _ -> 1
| Evar v -> 1 | Evar v -> 1
| Ecall (n, el) -> 1 + List.fold_left (fun acc e -> acc + (size_expr e)) 0 el
let rec size_instr (i: cfg_node) : int = let rec size_instr (i: cfg_node) : int =
match (i : cfg_node) with match (i : cfg_node) with
...@@ -71,6 +76,7 @@ let rec size_instr (i: cfg_node) : int = ...@@ -71,6 +76,7 @@ let rec size_instr (i: cfg_node) : int =
| Cprint (e, s) -> 1 + (size_expr e) | Cprint (e, s) -> 1 + (size_expr e)
| Ccmp (e, s1, s2) -> 1 + size_expr e | Ccmp (e, s1, s2) -> 1 + size_expr e
| Cnop s -> 1 | Cnop s -> 1
| Ccall (n, el, s) -> 1 + List.fold_left (fun acc e -> acc + (size_expr e)) 0 el
let size_fun f = let size_fun f =
Hashtbl.fold (fun k v acc -> acc + size_instr v) f 0 Hashtbl.fold (fun k v acc -> acc + size_instr v) f 0
......
...@@ -11,10 +11,20 @@ open Options ...@@ -11,10 +11,20 @@ open Options
(* [simple_eval_eexpr e] evaluates an expression [e] with no variables. Raises (* [simple_eval_eexpr e] evaluates an expression [e] with no variables. Raises
an exception if the expression contains variables. *) an exception if the expression contains variables. *)
let rec simple_eval_eexpr (e: expr) : int = let rec simple_eval_eexpr (e: expr) : int =
let st = init_state 0 in match e with
match eval_cfgexpr st e with | Ebinop(b, e1, e2) ->
| OK result -> Printf.printf "%d\n" result;result let v1 = simple_eval_eexpr e1 in
| Error s -> failwith "There was a var" let v2 = simple_eval_eexpr e2 in
let v = eval_binop b v1 v2 in
v
| Eunop(u, e) ->
let v1 = simple_eval_eexpr e in
let v = (eval_unop u v1) in
v
| Eint i -> i
| Ecall (name,_) -> failwith (Printf.sprintf "tried to call %s" name)
| _ -> failwith "unevaluable expr (const propagation)"
(* If an expression contains variables, we cannot simply evaluate it. *) (* If an expression contains variables, we cannot simply evaluate it. *)
...@@ -25,6 +35,7 @@ let rec has_vars (e: expr) = ...@@ -25,6 +35,7 @@ let rec has_vars (e: expr) =
| Evar(str) -> true | Evar(str) -> true
| Eunop(_,e') -> has_vars e' | Eunop(_,e') -> has_vars e'
| Ebinop(_,e',e'') -> has_vars e' || has_vars e'' | Ebinop(_,e',e'') -> has_vars e' || has_vars e''
| Ecall(_,el) -> true
let const_prop_binop b e1 e2 = let const_prop_binop b e1 e2 =
let e = Ebinop (b, e1, e2) in let e = Ebinop (b, e1, e2) in
...@@ -42,7 +53,12 @@ let const_prop_unop u e = ...@@ -42,7 +53,12 @@ let const_prop_unop u e =
let rec const_prop_expr (e: expr) = let rec const_prop_expr (e: expr) =
if has_vars e if has_vars e
then e then e
else Eint (simple_eval_eexpr e) else match e with
| Ebinop(_,_,_)
| Eunop(_,_)
| Eint(_) -> Eint (simple_eval_eexpr e)
| Ecall(name,el) -> Ecall(name, List.map const_prop_expr el)
| _ -> e
let constant_propagation_instr (i: cfg_node) : cfg_node = let constant_propagation_instr (i: cfg_node) : cfg_node =
match i with match i with
...@@ -51,6 +67,7 @@ let constant_propagation_instr (i: cfg_node) : cfg_node = ...@@ -51,6 +67,7 @@ let constant_propagation_instr (i: cfg_node) : cfg_node =
| Cprint(e, n) -> Cprint(const_prop_expr e, n) | Cprint(e, n) -> Cprint(const_prop_expr e, n)
| Ccmp(e,n,n') -> Ccmp(const_prop_expr e, n, n') | Ccmp(e,n,n') -> Ccmp(const_prop_expr e, n, n')
| Cnop(n) -> Cnop(n) | Cnop(n) -> Cnop(n)
| Ccall(str, el, n) -> Ccall(str, List.map const_prop_expr el, n)
let constant_propagation_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) = let constant_propagation_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
let ht = Hashtbl.map (fun n m -> let ht = Hashtbl.map (fun n m ->
......
...@@ -25,7 +25,9 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res = ...@@ -25,7 +25,9 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res =
| Elang.Eint i -> OK (Eint i) | Elang.Eint i -> OK (Eint i)
| Elang.Evar v -> | Elang.Evar v ->
OK (Evar v) OK (Evar v)
| Elang.Ecall(name, elist) ->
let* args_expr = list_map_res (cfg_expr_of_eexpr) elist in
OK(Cfg.Ecall(name, args_expr))
(* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond (* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond
to the E instruction [i]. to the E instruction [i].
...@@ -55,7 +57,7 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t) ...@@ -55,7 +57,7 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
Hashtbl.replace cfg next (Ccmp(c, nthen, nelse)); OK (next, next + 1) Hashtbl.replace cfg next (Ccmp(c, nthen, nelse)); OK (next, next + 1)
| Elang.Iwhile (c, i) -> | Elang.Iwhile (c, i) ->
cfg_expr_of_eexpr c >>= fun c -> cfg_expr_of_eexpr c >>= fun c ->
let (cmp, next) = (next, next+1) in let (cmp, next) = (next, next + 1) in
cfg_node_of_einstr next cfg cmp i >>= fun (nthen, next) -> cfg_node_of_einstr next cfg cmp i >>= fun (nthen, next) ->
Hashtbl.replace cfg cmp (Ccmp(c, nthen, succ)); OK (cmp, next + 1) Hashtbl.replace cfg cmp (Ccmp(c, nthen, succ)); OK (cmp, next + 1)
| Elang.Iblock il -> | Elang.Iblock il ->
...@@ -70,6 +72,11 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t) ...@@ -70,6 +72,11 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
cfg_expr_of_eexpr e >>= fun e -> cfg_expr_of_eexpr e >>= fun e ->
Hashtbl.replace cfg next (Cprint (e,succ)); Hashtbl.replace cfg next (Cprint (e,succ));
OK (next, next + 1) OK (next, next + 1)
| Elang.Icall(name, elist) ->
let* args_expr = list_map_res (cfg_expr_of_eexpr) elist in
Hashtbl.replace cfg next (Ccall(name, args_expr, succ));
OK (next,next+1)
(* Some nodes may be unreachable after the CFG is entirely generated. The (* Some nodes may be unreachable after the CFG is entirely generated. The
[reachable_nodes n cfg] constructs the set of node identifiers that are [reachable_nodes n cfg] constructs the set of node identifiers that are
...@@ -82,6 +89,7 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) = ...@@ -82,6 +89,7 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
| None -> reach | None -> reach
| Some (Cnop succ) | Some (Cnop succ)
| Some (Cprint (_, succ)) | Some (Cprint (_, succ))
| Some (Ccall(_,_,succ))
| Some (Cassign (_, _, succ)) -> reachable_aux succ reach | Some (Cassign (_, _, succ)) -> reachable_aux succ reach
| Some (Creturn _) -> reach | Some (Creturn _) -> reach
| Some (Ccmp (_, s1, s2)) -> | Some (Ccmp (_, s1, s2)) ->
......
...@@ -12,6 +12,7 @@ let rec vars_in_expr (e: expr) = ...@@ -12,6 +12,7 @@ let rec vars_in_expr (e: expr) =
| Eint(i) -> Set.empty | Eint(i) -> Set.empty
| Eunop(_,e1) -> vars_in_expr e1 | Eunop(_,e1) -> vars_in_expr e1
| Ebinop(_,e1,e2) -> Set.union (vars_in_expr e1) (vars_in_expr e2) | Ebinop(_,e1,e2) -> Set.union (vars_in_expr e1) (vars_in_expr e2)
| Ecall(_,el) -> List.fold_left (fun acc expr -> Set.union acc (vars_in_expr expr)) Set.empty el
(* [live_cfg_node node live_after] renvoie l'ensemble des variables vivantes (* [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 avant un nœud [node], étant donné l'ensemble [live_after] des variables
...@@ -20,9 +21,11 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) = ...@@ -20,9 +21,11 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
match node with match node with
| Cnop(n) -> live_after | Cnop(n) -> live_after
| Cassign(str, e,n) -> Set.union (vars_in_expr e) (Set.diff live_after (Set.singleton str)) | Cassign(str, e,n) -> Set.union (vars_in_expr e) (Set.diff live_after (Set.singleton str))
| Creturn(e) -> Set.union (vars_in_expr e) live_after | Creturn(e)
| Cprint(e,n) -> Set.union (vars_in_expr e) live_after | Cprint(e,_)
| Ccmp(e,n,n') -> Set.union (vars_in_expr e) live_after | Ccmp(e,_,_) -> Set.union (vars_in_expr e) live_after
| Ccall(str, el, n) -> List.fold_left (fun acc expr -> Set.union acc (vars_in_expr expr)) live_after el
(* [live_after_node cfg n] renvoie l'ensemble des variables vivantes après le (* [live_after_node cfg n] renvoie l'ensemble des variables vivantes après le
......
...@@ -9,8 +9,9 @@ let rec dump_cfgexpr : expr -> string = function ...@@ -9,8 +9,9 @@ let rec dump_cfgexpr : expr -> string = function
| Eunop(u, e) -> Format.sprintf "(%s %s)" (dump_unop u) (dump_cfgexpr e) | Eunop(u, e) -> Format.sprintf "(%s %s)" (dump_unop u) (dump_cfgexpr e)
| Eint i -> Format.sprintf "%d" i | Eint i -> Format.sprintf "%d" i
| Evar s -> Format.sprintf "%s" s | Evar s -> Format.sprintf "%s" s
| Ecall (name,el) -> Format.sprintf "%s(%s)" name (dump_list_cfgexpr el)
let dump_list_cfgexpr l = and dump_list_cfgexpr l =
l |> List.map dump_cfgexpr |> String.concat ", " l |> List.map dump_cfgexpr |> String.concat ", "
...@@ -18,6 +19,7 @@ let dump_arrows oc fname n (node: cfg_node) = ...@@ -18,6 +19,7 @@ let dump_arrows oc fname n (node: cfg_node) =
match node with match node with
| Cassign (_, _, succ) | Cassign (_, _, succ)
| Cprint (_, succ) | Cprint (_, succ)
| Ccall (_,_,succ)
| Cnop succ -> | Cnop succ ->
Format.fprintf oc "n_%s_%d -> n_%s_%d\n" fname n fname succ Format.fprintf oc "n_%s_%d -> n_%s_%d\n" fname n fname succ
| Creturn _ -> () | Creturn _ -> ()
...@@ -33,6 +35,7 @@ let dump_cfg_node oc (node: cfg_node) = ...@@ -33,6 +35,7 @@ let dump_cfg_node oc (node: cfg_node) =
| Creturn e -> Format.fprintf oc "return %s" (dump_cfgexpr e) | Creturn e -> Format.fprintf oc "return %s" (dump_cfgexpr e)
| Ccmp (e, _, _) -> Format.fprintf oc "%s" (dump_cfgexpr e) | Ccmp (e, _, _) -> Format.fprintf oc "%s" (dump_cfgexpr e)
| Cnop _ -> Format.fprintf oc "nop" | Cnop _ -> Format.fprintf oc "nop"
| Ccall (n,el,_) -> Format.fprintf oc "%s(%s)" n (dump_list_cfgexpr el)
let dump_liveness_state oc ht state = let dump_liveness_state oc ht state =
......
...@@ -7,52 +7,76 @@ open Cfg ...@@ -7,52 +7,76 @@ open Cfg
open Utils open Utils
open Builtins open Builtins
let rec eval_cfgexpr st (e: expr) : int res = let rec eval_cfgexpr oc cp st (e: expr) : (int * int Prog.state) res =
match e with match e with
| Ebinop(b, e1, e2) -> | Ebinop(b, e1, e2) ->
eval_cfgexpr st e1 >>= fun v1 -> let* (v1, st) = eval_cfgexpr oc cp st e1 in
eval_cfgexpr st e2 >>= fun v2 -> let* (v2, st) = eval_cfgexpr oc cp st e2 in
let v = eval_binop b v1 v2 in let v = eval_binop b v1 v2 in
OK v OK (v, st)
| Eunop(u, e) -> | Eunop(u, e) ->
eval_cfgexpr st e >>= fun v1 -> let* (v1,st) = eval_cfgexpr oc cp st e in
let v = (eval_unop u v1) in let v = (eval_unop u v1) in
OK v OK (v, st)
| Eint i -> OK i | Eint i -> OK (i, st)
| Evar s -> | Evar s ->
begin match Hashtbl.find_option st.env s with 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) | None -> Error (Printf.sprintf "Unknown variable %s\n" s)
end end
| Ecall(name,el) ->
let* f = find_function cp name in
let* (params, st) = List.fold_left (fun acc expr ->
let* (expr_list,st) = acc in
let* (new_expr, st) = eval_cfgexpr oc cp st expr in
OK(expr_list@[new_expr], st)
) (OK([],st)) el in
let* (i,st) = eval_cfgfun cp oc st name f params in
match i with
| None -> Error (Printf.sprintf "Error while runing %s" name)
| Some(i) -> OK(i,st)
let rec eval_cfginstr oc st ht (n: int): (int * int state) res = and eval_cfginstr cp oc st ht (n: int): (int * int state) res =
match Hashtbl.find_option ht n with match Hashtbl.find_option ht n with
| None -> Error (Printf.sprintf "Invalid node identifier\n") | None -> Error (Printf.sprintf "Invalid node identifier\n")
| Some node -> | Some node ->
match node with match node with
| Cnop succ -> | Cnop succ ->
eval_cfginstr oc st ht succ eval_cfginstr cp oc st ht succ
| Cassign(v, e, succ) -> | Cassign(v, e, succ) ->
eval_cfgexpr st e >>= fun i -> let* (i, st) = eval_cfgexpr oc cp st e in
Hashtbl.replace st.env v i; Hashtbl.replace st.env v i;
eval_cfginstr oc st ht succ eval_cfginstr cp oc st ht succ
| Ccmp(cond, i1, i2) -> | Ccmp(cond, i1, i2) ->
eval_cfgexpr st cond >>= fun i -> let* (i,st) = eval_cfgexpr oc cp st cond in
if i = 0 then eval_cfginstr oc st ht i2 else eval_cfginstr oc st ht i1 if i = 0 then eval_cfginstr cp oc st ht i2 else eval_cfginstr cp oc st ht i1
| Creturn(e) -> | Creturn(e) ->
eval_cfgexpr st e >>= fun e -> let* (e,st) = eval_cfgexpr oc cp st e in
OK (e, st) OK (e, st)
| Cprint(e, succ) -> | Cprint(e, succ) ->
eval_cfgexpr st e >>= fun e -> let* (e, st) = eval_cfgexpr oc cp st e in
Format.fprintf oc "%d\n" e; Format.fprintf oc "%d\n" e;
eval_cfginstr oc st ht succ eval_cfginstr cp oc st ht succ
| Ccall(name, el, s) ->
let* f = find_function cp name in
let* (params, st) = List.fold_left (fun acc expr ->
let* (expr_list,st) = acc in
let* (new_expr, st) = eval_cfgexpr oc cp st expr in
OK(expr_list@[new_expr], st)
) (OK([],st)) el in
let* (i,st) = eval_cfgfun cp oc st name f params in
match i with
| None -> Error (Printf.sprintf "Error while runing %s" name)
| Some(i) -> OK(i,st)
let eval_cfgfun oc st cfgfunname { cfgfunargs;
and eval_cfgfun cp oc st cfgfunname { cfgfunargs;
cfgfunbody; cfgfunbody;
cfgentry} vargs = cfgentry} vargs =
let st' = { st with env = Hashtbl.create 17 } in let st' = { st with env = Hashtbl.create 17 } in
match List.iter2 (fun a v -> Hashtbl.replace st'.env a v) cfgfunargs vargs with 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 cp oc st' cfgfunbody cfgentry >>= fun (v, st') ->
OK (Some v, {st' with env = st.env}) OK (Some v, {st' with env = st.env})
| exception Invalid_argument _ -> | exception Invalid_argument _ ->
Error (Format.sprintf "CFG: Called function %s with %d arguments, expected %d.\n" Error (Format.sprintf "CFG: Called function %s with %d arguments, expected %d.\n"
...@@ -64,7 +88,7 @@ let eval_cfgprog oc cp memsize params = ...@@ -64,7 +88,7 @@ let eval_cfgprog oc cp memsize params =
find_function cp "main" >>= fun f -> find_function cp "main" >>= fun f ->
let n = List.length f.cfgfunargs in let n = List.length f.cfgfunargs in
let params = take n params in let params = take n params in
eval_cfgfun oc st "main" f params >>= fun (v, st) -> eval_cfgfun cp oc st "main" f params >>= fun (v, st) ->
OK v OK v
...@@ -74,7 +74,7 @@ let list_regexp : (regexp * (string -> token option)) list = ...@@ -74,7 +74,7 @@ let list_regexp : (regexp * (string -> token option)) list =
(keyword_regexp "if", fun s -> Some (SYM_IF)); (keyword_regexp "if", fun s -> Some (SYM_IF));
(keyword_regexp "else", fun s -> Some (SYM_ELSE)); (keyword_regexp "else", fun s -> Some (SYM_ELSE));
(keyword_regexp "return", fun s -> Some (SYM_RETURN)); (keyword_regexp "return", fun s -> Some (SYM_RETURN));
(keyword_regexp "print", fun s -> Some (SYM_PRINT)); (* (keyword_regexp "print", fun s -> Some (SYM_PRINT)); *)
(keyword_regexp "struct", fun s -> Some (SYM_STRUCT)); (keyword_regexp "struct", fun s -> Some (SYM_STRUCT));
(keyword_regexp ".", fun s -> Some (SYM_POINT)); (keyword_regexp ".", fun s -> Some (SYM_POINT));
(keyword_regexp "+", fun s -> Some (SYM_PLUS)); (keyword_regexp "+", fun s -> Some (SYM_PLUS));
......
...@@ -12,6 +12,7 @@ type expr = ...@@ -12,6 +12,7 @@ type expr =
| Eunop of unop * expr | Eunop of unop * expr
| Eint of int | Eint of int
| Evar of string | Evar of string
| Ecall of string * expr list
type instr = type instr =
| Iassign of string * expr | Iassign of string * expr
...@@ -20,6 +21,7 @@ type instr = ...@@ -20,6 +21,7 @@ type instr =
| Iblock of instr list | Iblock of instr list
| Ireturn of expr | Ireturn of expr
| Iprint of expr | Iprint of expr
| Icall of string * expr list
type efun = { type efun = {
funargs: ( string ) list; funargs: ( string ) list;
......
...@@ -45,7 +45,7 @@ let tag_is_unary_inst = ...@@ -45,7 +45,7 @@ let tag_is_unary_inst =
| Tprint -> true | Tprint -> true
| _ -> false | _ -> false
let uniinst_of_tag e= let uniinst_of_tag e =
function function
Treturn -> Ireturn e Treturn -> Ireturn e
| Tprint -> Iprint e | Tprint -> Iprint e
...@@ -57,6 +57,14 @@ let uniinst_of_tag e= ...@@ -57,6 +57,14 @@ let uniinst_of_tag e=
let rec make_eexpr_of_ast (a: tree) : expr res = let rec make_eexpr_of_ast (a: tree) : expr res =
let res = let res =
match a with match a with
| Node(Tcall, StringLeaf(name)::r) ->
let args_list = (match r with
| Node(Targs, l )::[] -> l
| _ -> []
) in
list_map_res (fun e -> make_eexpr_of_ast e) args_list >>= fun args_expr ->
OK (Ecall(name, args_expr))
| Node(t, [e1; e2]) when tag_is_binop t -> | Node(t, [e1; e2]) when tag_is_binop t ->
make_eexpr_of_ast e1 >>= fun expr1 -> make_eexpr_of_ast e1 >>= fun expr1 ->
make_eexpr_of_ast e2 >>= fun expr2 -> make_eexpr_of_ast e2 >>= fun expr2 ->
...@@ -77,6 +85,16 @@ let rec make_eexpr_of_ast (a: tree) : expr res = ...@@ -77,6 +85,16 @@ let rec make_eexpr_of_ast (a: tree) : expr res =
let rec make_einstr_of_ast (a: tree) : instr res = let rec make_einstr_of_ast (a: tree) : instr res =
let res =