open Pp open Code type code = stm list (* commutation des expressions *) (* une astuce: on représente la lecture ou écriture en mémoire comme la lecture ou l'écriture dans un registre particulier *) let memory = Gen.new_temp();; let rec lus_dans_exp = function | Const _ -> [] | Name _ -> [] | Bin (_, e1, e2) -> lus_dans_exp e1 @ lus_dans_exp e2 | Mem e -> memory :: lus_dans_exp e | Temp t -> [t] | Call (_, _) -> assert false (* code non linéaire *) let rec écrits_dans_stm = function | [] -> [] | h :: rest -> match h with | Label _ -> écrits_dans_stm rest | Move_temp (t, Call (_,_)) -> t :: memory :: écrits_dans_stm rest | Move_temp (t, e) -> t :: écrits_dans_stm rest | Move_mem (_, e) -> memory :: écrits_dans_stm rest | Exp _ -> écrits_dans_stm rest | Seq _ -> assert false (* code canonique *) | Jump _ | Cjump (_,_,_,_,_) -> assert false (* code non linéaire *) (* une bonne approximation *) let rec commute e stm = (* fait l'hypothèse que e et stm sont canoniques et linéaire *) (* (* une mauvaise approximation mais presque suffisante *) stm = [] || lus_dans_exp e = [] *) let r = lus_dans_exp e and w = écrits_dans_stm stm in List.for_all (fun x -> not (List.mem x r)) w ;; (* canonisation des expressions et des instructions *) let rec rewrite_exp = function | Bin (binop, e1, e2) -> let s, [e1'; e2'] = rewrite_args [e1;e2] in s, Bin (binop, e1', e2') | Mem e -> let s, [e'] = rewrite_args [e] in s, Mem e | Call (f, el) -> let s, el' = rewrite_args el in let t = Gen.new_temp() in s @ [ Move_temp (t, Call (f, el')) ], Temp t | e -> [], e and rewrite_stm = function | Cjump (relop, e1, e2, l1, l2) -> let s, [e1'; e2'] = rewrite_args [e1;e2] in s @ [ Cjump (relop, e1', e2', l1, l2)] | Move_mem (e1, e2) -> let s, [e1'; e2'] = rewrite_args [e1;e2] in s @ [ Move_mem (e1', e2') ] | Move_temp (t, Call (f, el)) -> let s, el' = rewrite_args el in s @ [ Move_temp (t, Call (f, el')) ] | Move_temp (t, e1) -> let s, e1' = rewrite_exp e1 in s @ [ Move_temp (t, e1') ] | Exp (Call (f, el)) -> let s, el' = rewrite_args el in s @ [Exp (Call (f, el'))] | Exp e -> let s, e' = rewrite_exp e in s @ [Exp e'] | Seq s -> List.concat (List.map rewrite_stm s) | (Jump _ | Label _) as s -> [s] and rewrite_args = function [] -> [], [] | e :: el -> let s_el, el' = rewrite_args el in let s_e, e' = rewrite_exp e in if commute e' s_el then s_e @ s_el, e' :: el' else let t = Gen.new_temp() in s_e @ (Move_temp (t, e') :: s_el), Temp t :: el' ;; (* linéarisation du code *) let linearize l = List.concat (List.map rewrite_stm l) (* On coupe le code en basic-blocs *) type basic_block = {lab : Gen.label; succ : Gen.label list; block : stm list} let rec basic_finish lab block = function | (Jump l1 as s):: l -> { lab = lab; succ = [l1]; block = List.rev (s :: block); } :: basic_blocks l | Cjump (_,_,_, l1, l2) as s :: l -> { lab = lab; succ = [l1;l2]; block = List.rev (s :: block); } :: basic_blocks l | Label l1 as s :: l -> { lab = lab; succ = [l1]; block = List.rev (Jump l1 :: block); } :: basic_finish l1 [s] l | s :: l -> basic_finish lab (s :: block) l | [] -> failwith "basic_finish" and basic_blocks = function Label lab as s :: l -> basic_finish lab [s] l | [] -> [] | _ -> failwith "basic_start" let neg = function | Req -> Rne | Rne -> Req | Rle -> Rgt | Rge -> Rlt | Rlt -> Rge | Rgt -> Rle (* Après avoir éliminé les sauts en cascades, il faut identifier les étiquettes équivalentes *) let join_labels f code = let labels = ref [] in let rec join = function (Label l1 as instr :: (Label l2 :: code)) when l1 <> Frame.frame_name f -> (* il faut garder l'entrée des fonctions car le prélude sera inséré entre les deux *) labels := (l2, l1) :: !labels; join (instr :: code) | instr :: code -> instr :: join code | [] -> [] in let patch = function Jump l1 as s -> begin try Jump (List.assoc l1 !labels) with Not_found -> s end | Cjump (op, e1, e2, l1, l2) -> let l1 = try List.assoc l1 !labels with Not_found -> l1 in let l2 = try List.assoc l2 !labels with Not_found -> l2 in Cjump (op, e1, e2, l1, l2) | instr -> instr in let new_code = join code in List.map patch new_code;; (** le calcul des traces **) let trace frame blocks = (* table pour l'élimination des cascades de sauts *) let lab2block' = Hashtbl.create 13 in (* pour eliminer les cascades de sauts, sauf vers l'epilogue *) let rec follow l1 = try match (Hashtbl.find lab2block' l1).block with [Label _; Jump l2] when l2 <> Frame.frame_return frame -> follow l2 | _ -> l1 with Not_found -> l1 in List.iter (fun b -> Hashtbl.add lab2block' b.lab b) blocks; (* le netoyage à la fin de la trace *) let rec filter_trace = function | Cjump (binop, c1, c2, l1, l2) :: t -> begin match t with | Label l3 :: t3 when l1 = l3 -> Cjump (neg binop, c1, c2, follow l2, l1) :: Label l3 :: filter_trace t3 | Label l3 :: t3 when l2 = l3 -> Cjump (binop, c1, c2, follow l1, l2) :: Label l3 :: filter_trace t3 | _ -> let l4 = Gen.new_label () in Cjump (binop, c1, c2, follow l1, l4) :: Label l4 :: Jump l2 :: filter_trace t end | Jump l1 :: Label l2 :: t when l1 = l2 -> Label l2 :: filter_trace t | Jump l1 :: t -> Jump (follow l1) :: filter_trace t | h :: t -> h :: filter_trace t | [] -> [] in (* table pour le calcul des traces *) let lab2block = Hashtbl.create 13 in let rec find_succ = function [] -> raise Not_found (* toutes les étiquettes sont déjà tracées *) | h::t -> Hashtbl.find lab2block h (* raise Not_found si une étiquette n'est pas définie localement, par exemple un appel ou un retour de procédure *) in let rec extend (lab, succ, trace) b = Hashtbl.remove lab2block b.lab; let new_trace = b.block :: trace in try extend (lab, b.succ, new_trace) (find_succ b.succ) with Not_found -> (* le successeur n'est pas encore défini ou déjà tracé: on est en bout de trace, on rassemble les blocs accumulés dans un nouveau bloc. *) {lab = lab; succ = succ; block = List.concat (List.rev new_trace)} in let rec cumulate = function | b :: t -> begin try let _ = Hashtbl.find lab2block b.lab in let r = extend (b.lab, b.succ, []) b in r :: cumulate t with Not_found -> cumulate t end | [] -> [] in let code = [blocks] in (* (* Une version meilleurs utilise les composante fortement connexes mais en fait il faudrait plutôt considérer l'arbre des dominateurs pour avoir une amélioration significative *) let code = (* calcul les successeurs des basics blocs *) let rec all_succ = function [] -> [] | h::t -> try Hashtbl.find lab2block' h :: all_succ t with Not_found -> all_succ t in let succ b = all_succ b.succ in (* retournes les composantes connexes des basics blocks dans un ordre de non dépendance : les premières composantes n'appellent pas les suivantes *) Scc.components blocks succ in (* to trace components if necessary *) let print l = let printc l = List.iter (fun b-> Printf.fprintf stderr " %s" (Gen.label_string b.lab)) l; Printf.fprintf stderr "\n"; in Printf.fprintf stderr "Components:\n"; List.iter printc l; in print code; *) let rec glue = function [] -> [] | h1::h2::t -> List.iter (fun b -> Hashtbl.add lab2block b.lab b) h1; let h1' = cumulate h1 in glue ((h1' @ h2) :: t) | [h] -> List.iter (fun b -> Hashtbl.add lab2block b.lab b) h; List.concat (List.map (fun b -> b.block) (cumulate h)) in let t = glue (List.rev code) in filter_trace t ;; let canon_code f c = trace f (basic_blocks (join_labels f (linearize c))) open Trans let map f p = { number_of_globals = p.number_of_globals; main = f p.main; procedures = List.map f p.procedures; } ;; let program p = map (function f, c -> f, canon_code f c) p;;