diff --git a/src/linear_gen.ml b/src/linear_gen.ml
index cd83debf7a2e680757984e414ceadd9f838af7cb..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,41 +21,39 @@ let rec succs_of_rtl_instrs il : int list =
(* effectue un tri topologique des blocs. *)
let sort_blocks (nodes: (int, rtl_instr list) Hashtbl.t) entry =
- let rec add_block order visited n =
+ let rec add_block order visited n : reg list * reg set =
(* TODO *)
- List.of_enum (Hashtbl.keys nodes)
- (*if Set.mem n visited
- then order
+ (*List.of_enum (Hashtbl.keys nodes)*)
+ if Set.mem n visited
+ then order, visited
else let succs = succs_of_rtl_instrs (Hashtbl.find nodes n)
- in List.concat( (order@[n]) :: List.map (add_block [] (Set.add n visited)) succs )*)
+ in List.fold_left (fun (ord, vis) s -> add_block ord vis s) (order@[n], Set.add n visited) succs
in
- add_block [] Set.empty entry
+ fst (add_block [] Set.empty entry)
(* Supprime les jumps inutiles (Jmp à un label défini juste en dessous). *)
let rec remove_useless_jumps (l: rtl_instr list) =
(* TODO *)
- l
- (*match l with
+ match l with
| [] -> []
| Rjmp l1::Rlabel l2::rest ->
if l1=l2
then Rlabel l2::remove_useless_jumps rest
else Rjmp l1::Rlabel l2::remove_useless_jumps rest
- | i::rest -> i::remove_useless_jumps rest*)
+ | i::rest -> i::remove_useless_jumps rest
(* Remove labels that are never jumped to. *)
let remove_useless_labels (l: rtl_instr list) =
(* TODO *)
- l
- (*List.filter (function
+ List.filter (function
Rlabel i -> List.exists (
function
Rbranch(_, _, _, j) -> j = i
| Rjmp j -> j = i
| _ -> false) l
- | _ -> true) l*)
+ | _ -> true) l
let linear_of_rtl_fun
({ rtlfunargs; rtlfunbody; rtlfunentry; rtlfuninfo }: rtl_fun) =
diff --git a/src/rtl.ml b/src/rtl.ml
index 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 7955b3fe97c68b8cbe7ecdaa4e33811d1d93437e..e49d304f4b9e73e7859a18212522e75e1a542809 100644
--- a/src/rtl_gen.ml
+++ b/src/rtl_gen.ml
@@ -53,6 +53,14 @@ let rec rtl_instrs_of_cfg_expr (next_reg, var2reg) (e: expr) =
| Eunop (u, e) ->
let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) e
in (next_reg', l@[Runop(u, next_reg', r)], next_reg'+1, var2reg')
+ | Ecall (f, args) ->
+ let regs, l, next_reg', var2reg' =
+ List.fold_left
+ (fun (regs, instrs, next_reg, var2reg) arg ->
+ let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) arg
+ in (regs@[r], instrs@l, next_reg', var2reg'))
+ ([], [], next_reg, var2reg) args
+ in (next_reg', l@[Rcall (Some next_reg', f, regs)], next_reg' + 1, var2reg')
let is_cmp_op =
function Eclt -> Some Rclt
@@ -89,8 +97,16 @@ let rtl_instrs_of_cfg_node ((next_reg:int), (var2reg: (string*int) list)) (c: cf
let cmp, e1, e2 = rtl_cmp_of_cfg_expr e
in let r1, l1, next_reg1, var2reg1 = rtl_instrs_of_cfg_expr (next_reg, var2reg) e1
in let r2, l2, next_reg2, var2reg2 = rtl_instrs_of_cfg_expr (next_reg1, var2reg1) e2
- in (l1@l2@[Rbranch(cmp, r1, r2, i1)]@[Rjmp i2], next_reg2, var2reg2)
+ in (l1@l2@[Rbranch(cmp, r1, r2, i1); Rjmp i2], next_reg2, var2reg2)
| Cnop i -> ([Rjmp i], next_reg, var2reg)
+ | Ccall (f, args, i) ->
+ let regs, l, next_reg', var2reg' =
+ List.fold_left
+ (fun (regs, instrs, next_reg, var2reg) arg ->
+ let r, l, next_reg', var2reg' = rtl_instrs_of_cfg_expr (next_reg, var2reg) arg
+ in (regs@[r], instrs@l, next_reg', var2reg'))
+ ([], [], next_reg, var2reg) args
+ in (l@[Rcall (None, f, regs); Rjmp i], next_reg', var2reg')
let rtl_instrs_of_cfg_fun cfgfunname ({ cfgfunargs; cfgfunbody; cfgentry }: cfg_fun) =
let (rargs, next_reg, var2reg) =
diff --git a/src/rtl_print.ml b/src/rtl_print.ml
index 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