Commits

hogekura  committed 8e9aa20

10章を実装

  • Participants
  • Parent commits e96897a

Comments (0)

Files changed (5)

File src/OMakefile

 MENHIR_AVAILABLE = true
 MENHIR_ENABLED = true
 
-OCAMLFINDFLAGS += -syntax camlp4o -package menhirLib -package deriving-ocsigen.syntax -package deriving-ocsigen
+OCAMLFINDFLAGS += -syntax camlp4o -package menhirLib -package deriving-ocsigen.syntax -package deriving-ocsigen -package ocamlgraph
 
 CamlTargets(module)=
 	$(module).cmi:
 OCamlLibrary (main, canon find_escape frame temp loc tokens errormsg lex symbol absyn parser tiger_env tiger_types translate semant tree driver mylib)
 section
 	OCAMLFINDFLAGS += -linkpkg -package ulex
-	OCamlProgram (tiger, canon find_escape codegen assem frame temp loc tokens errormsg lex symbol absyn parser tiger_env tiger_types translate semant tree driver mylib)
+	OCamlProgram (tiger,loc mylib parser symbol temp tiger_types tokens tree errormsg canon assem absyn find_escape flow frame frame_sig lex liveness translate tiger_env semant codegen driver)
 .DEFAULT: main.cma tiger

File src/driver.ml

 module Tr = Translate ;;
 
 let main filename =
+  (* parse -> Translate *)
   let (exp, flags) =
     tee (parse filename) ~f:(debug ~message:"parse" Show.show<Absyn.exp>) |> Semant.trans_prog in
   debug ~message:"trans exp" Show.show<Tree.exp> (Tr.unEx exp.Semant.exp);
   debug ~message:"type" Show.show<Tiger_types.ty> (exp.Semant.ty);
 
+  (* linearize -> basic_block -> trace_scedule *)
   let canon stm =
     Canon.linearize stm
   |> tee ~f:(debug ~message:"linearize" Show.show<Tree.stm list>)
   |> uncurry Canon.trace_schedule
   |> tee ~f:(debug ~message:"trace_schedule" Show.show<Tree.stm list>) in
 
-  List.iter (fun p ->
+  (* cnaonical -> assem *)
+  List.iter flags ~f:(fun p ->
     tee p ~f:(debug ~message:"proc" Show.show<Tr.frag>) |> function
     | Translate.PROC (stm, frame) ->
       List.map (canon stm) ~f:(Codegen.codegen frame)
-    |> List.iter ~f:(
-      debug ~message:"-----------------------------------------"
-        (Show.show <Assem.instr list>))
-    | _ -> ()) flags;
+    |> List.concat 
+    |> tee ~f:(debug ~message:"-----------------------------------------"
+                 (Show.show <Assem.instr list>))
+    |> (fun assems ->
+      let (start, graph) = Flow.instrs_to_graph assems in
+      Liveness.interference_graph start graph |> ignore)
+    | _ -> ());
 
+  (* canonical -> assem *)
   List.map (canon (Tr.unNx exp.Semant.exp)) ~f:(Codegen.codegen Tr.outermost.Tr.frame)
   |> debug ~message:"main"
       (fun ss -> Show.show <Assem.instr list> @@ List.concat ss)
+open Mylib ;;
+
+type vlabel = {use : Temp.temp list; def : Temp.temp list; is_move : bool}
+  
+module G = Graph.Persistent.Digraph.ConcreteLabeled (struct
+  type t = vlabel
+  let compare = compare
+  let hash = Hashtbl.hash
+  let equal = (=)
+end) (struct
+  type t = Temp.label option ;;
+  let compare x y = compare x y
+  let default = None
+end)
+;;
+
+module LMap = Map.Make (struct
+  type t = Temp.label
+  let compare = compare
+end)
+;;
+
+let instrs_to_graph instrs =
+  let open Assem in
+
+  let (start, is) = match instrs with
+  | [] -> assert false
+  | i :: is -> (i, is) in
+  
+  let to_node g vs lset i =
+    match i with
+    | OPER op ->
+      let v = G.V.create {use = op.op_src; def = op.op_dst; is_move = false} in
+      (G.add_vertex g v, (v, i) :: vs, lset)
+    | LABEL lb ->
+      let v = G.V.create {use = []; def = []; is_move = false} in
+      (G.add_vertex g v, (v, i) :: vs, LMap.add lb.lab v lset)
+    | MOVE mv ->
+      let v = G.V.create {use = [mv.mv_src]; def = [mv.mv_dst]; is_move = true} in
+      (G.add_vertex g v, (v, i) :: vs, lset) in
+  
+  let (_, start_node, _) as init_state = to_node G.empty [] LMap.empty start in
+  let start_node = match start_node with
+  | [(start_node, _)] -> start_node 
+  | _ -> assert false in
+  
+  let (graph, vs, label_set) =
+    List.fold_left instrs ~init:init_state ~f:(fun (g, vs, lset) i ->
+      to_node g vs lset i) in
+
+  let (_, graph) = List.fold_left ~init:(start_node, graph) (List.rev vs |> List.tl)
+    ~f:(fun (prev, g) (v, _) ->
+      (v, G.add_edge_e g (G.E.create prev None v))) in
+  
+  let graph = List.fold_left vs ~init:graph ~f:(fun g i ->
+    match i with
+    | (v, OPER op) ->
+      let js = match op.jump with
+      | None -> []
+      | Some ls -> List.map ls ~f:(fun l -> (l, LMap.find l label_set)) in
+      List.fold_left ~init:graph js ~f:(fun graph (l, v') ->
+        G.add_edge_e g (G.E.create v (Some l) v'))
+    | _ -> g) in
+  (start_node, graph)
+;;

File src/liveness.ml

+open Mylib ;;
+
+module G = Graph.Persistent.Graph.ConcreteLabeled (struct
+  type t = Temp.temp
+  let compare = compare
+  let hash = Hashtbl.hash
+  let equal = (=)
+end) (struct
+  type t = int
+  let compare = compare
+  let default = 0
+end)
+;;
+
+module FG = Flow.G ;;
+
+module TSet = Set.Make (struct
+  type t = Temp.temp
+  let compare = compare 
+end)
+;;
+
+module VMap = Map.Make (struct
+  type t = FG.V.t
+  let compare = compare
+end)
+;;
+
+let create_igraph out_fun g =
+  FG.fold_vertex (fun v acc ->
+    let outs = out_fun v in
+
+    if FG.V.((label v).Flow.is_move) then
+      let def, use = match v.Flow.def, v.Flow.use with
+      | [d], [u] -> d, u
+      | _   -> assert false in
+      List.fold_left outs ~init:acc ~f:(fun acc t1 ->
+        if t1 = use then acc
+        else G.add_edge acc (G.V.create t1) (G.V.create def))
+    else
+      List.fold_left outs ~init:acc ~f:(fun acc t1 ->
+        List.fold_left v.Flow.def ~init:acc ~f:(fun acc t2 ->
+          G.add_edge acc (G.V.create t1) (G.V.create t2))))
+    g G.empty
+;;
+
+let interference_graph start g =
+  let rec dfs v idx acc =
+    if VMap.mem v acc then (idx, acc)
+    else begin
+      let acc = VMap.add v idx acc in
+      let idx = succ idx in
+      FG.fold_succ (fun succ (idx, acc) -> dfs succ idx acc) g v (idx, acc) 
+    end in
+  
+  let (_, vmap) = dfs start 0 VMap.empty in
+  let order = VMap.bindings vmap |> List.sort ~cmp:(fun (_, i) (_, j) -> compare i j) in
+  
+  let nv = List.length order in
+  
+  let out =
+    let in_ = Array.create nv TSet.empty in
+    let out = Array.create nv TSet.empty in
+  
+    let in_' = Array.copy in_ in
+    let out' = Array.copy out in
+
+    let tset_of_list xs = List.fold_left ~init:TSet.empty xs ~f:(fun acc x -> TSet.add x acc) in
+    
+    let use = Array.create nv TSet.empty in
+    let def = Array.create nv TSet.empty in
+    List.iter order ~f:(fun (v, i) ->
+      use.(i) <- tset_of_list v.Flow.use;
+      def.(i) <- tset_of_list v.Flow.def);
+    
+    let rec iter () =
+      List.iter order ~f:(fun (v, i) ->
+        in_'.(i) <- in_.(i);
+        out'.(i) <- out.(i);
+        in_.(i) <- TSet.union use.(i) (TSet.diff out.(i) def.(i));
+        out.(i) <- FG.fold_succ (fun succ acc ->
+          let i = VMap.find succ vmap in
+          TSet.union acc in_.(i)) g v TSet.empty);
+
+      if Array.for_all2 in_ in_' ~f:(fun v1 v2 -> TSet.equal v1 v2) &&
+        Array.for_all2 out out' ~f:(fun v1 v2 -> TSet.equal v1 v2) then ()
+      else iter () in
+    
+    iter ();
+    Array.map out ~f:(fun v -> TSet.elements v) in
+  
+  let out_fun v = out.(VMap.find v vmap) in
+
+  (create_igraph out_fun g, out_fun)
+;;

File src/mylib.ml

   ;;
 end
 
-module Array = ArrayLabels ;;
+module Array = struct
+  include ArrayLabels ;;
+
+  let for_all ~f arr =
+    try
+      for i = 0 to Array.length arr - 1 do
+        if not (f arr.(i)) then raise Exit
+      done;
+      true
+    with
+    | Exit -> false ;;
+
+  let for_all2 ~f arr1 arr2 =
+    try
+      for i = 0 to Array.length arr1 - 1 do
+        if not (f arr1.(i) arr2.(i)) then raise Exit
+      done;
+      true
+    with
+    | Exit -> false ;;
+end