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) =

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

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

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)

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

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) =

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"

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