Fonction print + global OK jusque linear inclu

src/cfg.ml

@@ -13,7 +13,6 @@ type expr =
 type cfg_node =
   | Cassign of string * expr * int
   | Creturn of expr
-  | Cprint of expr * int
   | Ccmp of expr * int * int
   | Cnop of int
   | Ccall of string * expr list * int
@@ -32,7 +31,6 @@ type cprog = cfg_fun prog
 let succs cfg n =
   match Hashtbl.find_option cfg n with
   | None -> Set.empty
-  | Some (Cprint (_, s))
   | Some (Cassign (_, _, s)) -> Set.singleton s
   | Some (Creturn _) -> Set.empty
   | Some (Ccmp (_, s1, s2)) -> Set.of_list [s1;s2]
@@ -47,7 +45,6 @@ let preds cfgfunbody n =
       match m' with
       | Cassign (_, _, s)
       | Ccall (_, _, s)
-      | Cprint (_, s)
       | Cnop 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
@@ -75,7 +72,6 @@ let size_instr (i: cfg_node) : int =
   match (i : cfg_node) with
   | Cassign (_, e, _) -> 1 + size_expr e
   | Creturn e -> 1 + (size_expr e)
-  | Cprint (e, _) -> 1 + (size_expr e)
   | Ccmp (e, _, _) -> 1 + size_expr e
   | Cnop _ -> 1
   | Ccall (_,args,_) -> 1 + List.fold (fun acc arg -> acc + size_expr arg ) 0 args

src/cfg_dead_assign.ml

@@ -19,7 +19,7 @@ let dead_assign_elimination_fun ({ cfgfunbody; _ } as f: cfg_fun) =
     Hashtbl.map (fun (n: int) (m: cfg_node) ->
         match m with
            (* TODO *)
-        |Cassign (var,e,i) -> 
+        | Cassign (var,e,i) -> 
           begin 
             match Hashtbl.find_option (live_cfg_fun f ) i with
             | Some set_of_var -> if Set.mem var set_of_var  then m else (changed:= true ; (Cnop i ))

src/cfg_gen.ml

@@ -25,7 +25,8 @@ 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 (fname, args) -> OK (Ecall(fname,(List.map (fun arg -> cfg_expr_of_eexpr arg >>! fun expr -> expr) args)))
+  | Elang.Ecall (fname, args) -> 
+    OK (Ecall(fname,(List.map (fun arg -> cfg_expr_of_eexpr arg >>! fun expr -> expr) args)))
 
 (* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond
    to the E instruction [i].
@@ -45,34 +46,31 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res =
 let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
     (succ: int) (i: instr) : (int * int) res =
   match i with
-  | Elang.Iassign (v, e) ->
+  | Iassign (v, e) ->
     cfg_expr_of_eexpr e >>= fun e ->
     Hashtbl.replace cfg next (Cassign(v,e,succ));
     OK (next, next + 1)
-  | Elang.Iif (c, ithen, ielse) ->
+  | Iif (c, ithen, ielse) ->
     cfg_expr_of_eexpr c >>= fun c ->
     cfg_node_of_einstr next cfg succ ithen >>= fun (nthen, next) ->
     cfg_node_of_einstr next cfg succ ielse  >>= fun (nelse, next) ->
     Hashtbl.replace cfg next (Ccmp(c, nthen, nelse)); OK (next, next + 1)
-  | Elang.Iwhile (c, i) ->
+  | Iwhile (c, i) ->
     cfg_expr_of_eexpr c >>= fun c ->
     let (cmp, next) = (next, next+1) in
     cfg_node_of_einstr next cfg cmp i >>= fun (nthen, next) ->
     Hashtbl.replace cfg cmp (Ccmp(c, nthen, succ)); OK (cmp, next + 1)
-  | Elang.Iblock il ->
+  | Iblock il ->
     List.fold_right (fun i acc ->
         acc >>= fun (succ, next) ->
         cfg_node_of_einstr next cfg succ i
       ) il (OK (succ, next))
-  | Elang.Ireturn e ->
+  | Ireturn e ->
     cfg_expr_of_eexpr e >>= fun e ->
     Hashtbl.replace cfg next (Creturn e); OK (next, next + 1)
-  | Elang.Iprint e ->
-    cfg_expr_of_eexpr e >>= fun e ->
-    Hashtbl.replace cfg next (Cprint (e,succ));
-    OK (next, next + 1)
-    | Elang.Icall (fname,args) -> let list_of_cfg_args = List.map (fun arg -> cfg_expr_of_eexpr arg >>! fun expr -> expr) args in
-    Hashtbl.replace cfg next (Ccall (fname,list_of_cfg_args,next)) ; OK (next,next+1)
+  | Icall (fname,args) ->
+      let list_of_cfg_args = List.map (fun arg -> cfg_expr_of_eexpr arg >>! fun expr -> expr) args in
+      Hashtbl.replace cfg next (Ccall (fname,list_of_cfg_args,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
@@ -84,7 +82,6 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
       match Hashtbl.find_option cfg n with
       | None -> reach
       | Some (Cnop succ)
-      | Some (Cprint (_, succ))
       | Some (Ccall (_,_,succ))
       | Some (Cassign (_, _, succ)) -> reachable_aux succ reach
       | Some (Creturn _) -> reach

src/cfg_liveness.ml

@@ -34,14 +34,10 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
    match node with 
    | Cassign (s, e, i) -> Set.union (vars_in_expr e) (Set.diff live_after (Set.singleton s))
    | Creturn e -> vars_in_expr e
-   | Cprint (e,i) -> Set.union (vars_in_expr e) live_after
    | Ccmp (e,i1,i2) -> Set.union (vars_in_expr e) live_after
-   | Cnop i -> Set.empty
+   | Cnop i -> live_after
    | Ccall (fname,args,s) -> 
-      (List.fold (fun acc arg -> Set.union acc (vars_in_expr arg)) Set.empty args) 
-
-
-   
+      (List.fold (fun acc arg -> Set.union acc (vars_in_expr arg)) live_after args) 
 
 (* [live_cfg_nodes cfg lives] effectue une itération du calcul de point fixe.
 
@@ -55,11 +51,11 @@ let live_cfg_nodes cfg (lives : (int, string Set.t) Hashtbl.t) =
       let list_out = live_after_node cfg node_int lives in
       let list_in = live_cfg_node node list_out in
       match (Hashtbl.find_option lives node_int) with
-      |Some list_of_nodes -> 
+      | Some list_of_nodes -> 
          if Set.equal list_in list_of_nodes then acc
          else 
             (Hashtbl.replace lives node_int list_in ; true)
-      |None -> Hashtbl.replace lives node_int list_in ; true)
+      | None -> Hashtbl.replace lives node_int list_in ; true)
        false (List.sort compare @@ Hashtbl.to_list cfg) 
 
 (* [live_cfg_fun f] calcule l'ensemble des variables vivantes avant chaque nœud

src/cfg_print.ml

@@ -17,20 +17,18 @@ let dump_list_cfgexpr l =
 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) ->
     Format.fprintf oc "n_%s_%d -> n_%s_%d [label=\"then\"]\n" fname n fname succ1;
     Format.fprintf oc "n_%s_%d -> n_%s_%d [label=\"else\"]\n" fname n fname succ2
-  | Ccall (fname,args,s) -> ()
 
 
 let dump_cfg_node oc (node: cfg_node) =
   match node with
   | Cassign (v, e, _) -> Format.fprintf oc "%s = %s" v (dump_cfgexpr e)
-  | Cprint (e, _) -> Format.fprintf oc "print %s" (dump_cfgexpr e)
   | Creturn e -> Format.fprintf oc "return %s" (dump_cfgexpr e)
   | Ccmp (e, _, _) -> Format.fprintf oc "%s" (dump_cfgexpr e)
   | Cnop _ -> Format.fprintf oc "nop"

src/cfg_run.ml

@@ -49,16 +49,17 @@ and eval_cfginstr cp oc st ht (n: int): (int * int state) res =
     | Creturn(e) ->
       eval_cfgexpr cp oc st e >>= fun e ->
       OK (e, st)
-    | Ccall (funame,args,s) -> find_function cp funame >>! (fun f ->
+    | Ccall (funame,args,s) -> 
       let funargs = (List.map (fun arg -> eval_cfgexpr cp oc st arg >>! fun valeur -> valeur) args) in
       match do_builtin oc st.mem funame funargs with
-      | OK Some i -> Error "Nous n'attendons pas de retour ici"
+      | OK Some i -> Error "On n'attend pas de retour de fonction ici"
       | OK None -> eval_cfginstr cp oc st ht s
       | Error _ -> 
-        eval_cfgfun cp oc st funame f funargs >>! 
-        (fun (fun_result, new_state) -> 
-            OK (s,new_state)
-              ))
+        find_function cp funame >>! (fun f ->
+          eval_cfgfun cp oc st funame f funargs >>! 
+          (fun (fun_result, new_state) -> 
+            eval_cfginstr cp oc st ht s
+                ))
 
 and eval_cfgfun cp oc st cfgfunname { cfgfunargs;
                                       cfgfunbody;

src/elang.ml

@@ -17,7 +17,6 @@ type instr =
   | Iwhile of expr * instr
   | Iblock of instr list
   | Ireturn of expr
-  | Iprint of expr
   | Icall of string * expr list
 
 type efun = {

src/elang_gen.ml

@@ -72,8 +72,10 @@ let rec make_einstr_of_ast (a: tree) : instr res =
         make_eexpr_of_ast e >>= (fun expr ->
           OK (Iassign(s,expr)))
       | _ -> Error (Printf.sprintf "Pas encore d'autres options") end
+      
     | Node (Tcall,[StringLeaf(funname); Node(Targs, args)]) -> 
-      OK (Icall (funname,List.map (fun arg -> make_eexpr_of_ast arg >>! fun expr -> expr) args))   
+      OK (Icall (funname,List.map (fun arg -> make_eexpr_of_ast arg >>! fun expr -> expr) args))  
+       
     | Node(Tif,[e;i1;i2]) -> 
       make_eexpr_of_ast e >>= (fun expr ->
         make_einstr_of_ast i1 >>= fun instr1 ->
@@ -95,9 +97,7 @@ let rec make_einstr_of_ast (a: tree) : instr res =
     | Node( Treturn,[e]) -> 
       make_eexpr_of_ast e >>= fun expr ->  
       OK (Ireturn (expr) )
-    | Node(Tprint,[e]) -> 
-      make_eexpr_of_ast e >>= fun expr ->
-      OK (Iprint ( expr))
+
     | _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
                     (string_of_ast a))
   in

src/elang_print.ml

@@ -56,12 +56,9 @@ let rec dump_einstr_rec indent oc i =
   | Ireturn(e) ->
     print_spaces oc indent;
     Format.fprintf oc "return %s;\n" (dump_eexpr e)
-  | Iprint(e) ->
-    print_spaces oc indent;
-    Format.fprintf oc "print %s;\n" (dump_eexpr e)
   | Icall (funname, args) -> 
     print_spaces oc indent;
-    Format.fprintf oc "print %s(%s);\n" funname (String.concat "," (List.map dump_eexpr args))
+    Format.fprintf oc "%s(%s);\n" funname (String.concat "," (List.map dump_eexpr args))
 
 let dump_einstr oc i = dump_einstr_rec 0 oc i
 

src/elang_run.ml

@@ -108,7 +108,7 @@ and eval_einstr ep oc (st: int state) (ins: instr) :
       eval_eexpr ep oc st (e) >>= fun expr_evaluated -> OK (Some (expr_evaluated), st)
   | Icall (funame,args) -> 
    match do_builtin oc st.mem funame (List.map (fun arg -> eval_eexpr ep oc st arg >>! fun valeur -> valeur) args) with
-   | OK Some i -> OK (Some i,st)
+   | OK Some i -> Error "Pas de retour ici"
    | OK None -> OK (None, st)
    | Error _ -> 
       find_function ep funame >>! (fun f ->

src/linear_run.ml

@@ -60,6 +60,26 @@ 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, callee_fname, rargs) -> 
+    List.map (fun r -> Hashtbl.find st.regs r) rargs |> fun args ->
+    match do_builtin oc st.mem callee_fname args with
+    | OK Some i -> Error "On n'attend pas de retour de fonction ici"
+    | OK None -> OK (None,st)
+    | Error _ -> 
+      match find_function lp callee_fname with 
+      | OK f -> 
+        exec_linear_fun oc lp st callee_fname f args 
+        >>= fun (value,new_state) -> 
+          let value = Option.get value in
+        begin
+        match rd with
+          | Some rd ->
+              Hashtbl.replace new_state.regs rd value ;
+              OK (None,new_state)
+          | None -> OK (None,new_state)
+        end
+    | Error e -> Error e
+    
 
 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

@@ -220,8 +220,11 @@ let written_rtl_regs_instr (i: rtl_instr) =
   | Rret _
   | Rlabel _
   | Rbranch (_, _, _, _)
+  | Rcall (_,_,_)
   | Rjmp _ -> Set.empty
 
+
+
 let read_rtl_regs_instr (i: rtl_instr) =
   match i with
   | Rbinop (_, _, rs1, rs2)
@@ -234,6 +237,7 @@ let read_rtl_regs_instr (i: rtl_instr) =
 
   | Rlabel _
   | Rconst (_, _)
+  | Rcall (_,_,_)
   | Rjmp _ -> Set.empty
 
 let read_rtl_regs (l: rtl_instr list) =
@@ -318,14 +322,36 @@ let ltl_instrs_of_linear_instr fname live_out allocation
         parameter_passing @
         LCall "print" ::
         LComment "Restoring a0-a7,t0-t6" :: restore_caller_save arg_saved)
-
+  | Rcall (rd, callee_fname, rargs) ->
+      caller_save live_out allocation rargs
+      >>! fun to_save ->
+      let (save_a_regs, arg_saved, ofs) =  
+        save_caller_save
+          (List.of_seq (Set.to_seq to_save))
+          (- (numspilled+1)) in 
+      pass_parameters rargs allocation arg_saved 
+      >>= (fun (pass_param_instr,npush) ->
+        match rd with 
+        | Some rd -> 
+          OK ( pass_param_instr 
+          @ [LAddi (reg_sp , reg_sp , ofs)] 
+          @ [LCall callee_fname] 
+          @ [LMov (rd, reg_a0)] 
+          @ (restore_caller_save arg_saved))
+        | None ->
+          OK ( pass_param_instr @ [LCall callee_fname] 
+          @ [LAddi (reg_sp , reg_sp , npush)] 
+          @ (restore_caller_save arg_saved)))
   | Rret r ->
     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)]
-  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)
+    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)
+  
+       
 
 (** Retrieves the location of the n-th argument (in the callee). The first 8 are
    passed in a0-a7, the next are passed on the stack. *)

src/rtl_gen.ml

@@ -56,13 +56,13 @@ let rec rtl_instrs_of_cfg_expr (next_reg, var2reg) (e: expr) =
     let r, next_reg',var2reg' = find_var (next_reg, var2reg) s in 
     (r, [], next_reg', var2reg')
   | Ecall (fname, args) -> 
-    let r,instr,next_reg_after_call,var2reg_after_call = List.fold_left (
+    let rargs,instr,next_reg_after_call,var2reg_after_call = List.fold_left (
       fun acc arg -> 
       let (r_list,instr_list,next_rega,var2rega) = acc in 
       let (newr,newinstr,newnext_reg,newvar2reg) = rtl_instrs_of_cfg_expr (next_rega, var2rega) arg in
       (r_list @ [newr],instr_list @ newinstr , newnext_reg, newvar2reg)
     ) ([],[],next_reg, var2reg) args in
-    (next_reg_after_call,instr @ [Rcall(Some next_reg_after_call,fname,r)],next_reg_after_call +1,var2reg_after_call)
+    (next_reg_after_call,instr @ [Rcall(Some next_reg_after_call,fname,rargs)],next_reg_after_call +1,var2reg_after_call)
 
 
 let is_cmp_op =
@@ -91,8 +91,6 @@ let rtl_instrs_of_cfg_node ((next_reg:int), (var2reg: (string*int) list)) (c: cf
   (lexpr @ [Rmov(rass,rexpr);Rjmp (i)], next_regass, var2regass)
   | Creturn e -> let a,b,c,d = rtl_instrs_of_cfg_expr (next_reg,var2reg) e in 
   (b @[(Rret a)],c,d)
-  | Cprint (e,i) -> let a,b,c,d = rtl_instrs_of_cfg_expr (next_reg,var2reg) e in 
-  (b @[(Rprint a);Rjmp(i)],c ,d)
   | Ccmp (e,i1,i2) -> let rop,e1,e2 = rtl_cmp_of_cfg_expr e in
   let r1,rtlinstr1, next_reg1,var2reg1 = rtl_instrs_of_cfg_expr (next_reg, var2reg) e1 in
   let r2,rtlinstr2, next_reg2,var2reg2 = rtl_instrs_of_cfg_expr (next_reg1, var2reg1) e2 in

src/rtl_run.ml

@@ -79,20 +79,24 @@ let rec exec_rtl_instr oc rp rtlfunname f st (i: rtl_instr) =
   | Rlabel n -> OK (None, st)
   | Rcall (rd,fname,rargs) -> 
     List.map (fun r -> Hashtbl.find st.regs r) rargs |> fun args ->
-    find_function rp fname 
-    >>! fun f -> 
-    exec_rtl_fun oc rp st fname f args
-    >>! fun (fun_result,new_state) ->
-    match rd with
-    | None -> OK(None, new_state)
-    | Some r -> 
-        begin
-        match fun_result with
-        | Some result -> 
-          Hashtbl.replace new_state.regs r result;
-          OK (None,new_state)
-        | None -> Error "On s'attend à un retour de fonction ici"
-        end      
+    match do_builtin oc st.mem fname args with
+      | OK Some i -> Error "On n'attend pas de retour de fonction ici"
+      | OK None -> OK (None,st)
+      | Error _ -> 
+          find_function rp fname 
+          >>! fun f -> 
+          exec_rtl_fun oc rp st fname f args
+          >>! fun (fun_result,new_state) ->
+          match rd with
+          | None -> OK(None, new_state)
+          | Some r -> 
+              begin
+              match fun_result with
+              | Some result -> 
+                Hashtbl.replace new_state.regs r result;
+                OK (None,new_state)
+              | None -> Error "On s'attend à un retour de fonction ici"
+              end      
     
 
 and exec_rtl_instr_at oc rp rtlfunname ({ rtlfunbody;  } as f: rtl_fun) st i =

tests/Makefile

@@ -2,6 +2,7 @@
 # '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),funcall/*.e)
+# FILES += $(if $(DIR),$(DIR),funcall/*.e)
 
 OPTS := $(if $(OPTS), $(OPTS),)