asmcomp/schedgen.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Instruction scheduling *)
  16
  17 open Misc
  18 open Reg
  19 open Mach
  20 open Linearize
  21
  22 (* Representation of the code DAG. *)
  23
  24 type code_dag_node =
  25   { instr: instruction;                 (* The instruction *)
  26     delay: int;           (* How many cycles before result is available *)
  27     mutable sons: (code_dag_node * int) list;
  28                                         (* Instructions that depend on it *)
  29     mutable date: int;                  (* Start date *)
  30     mutable length: int;                (* Length of longest path to result *)
  31     mutable ancestors: int;             (* Number of ancestors *)
  32     mutable emitted_ancestors: int }    (* Number of emitted ancestors *)
  33
  34 let dummy_node =
  35   { instr = end_instr; delay = 0; sons = []; date = 0;
  36     length = -1; ancestors = 0; emitted_ancestors = 0 }
  37
  38 (* The code dag itself is represented by two tables from registers to nodes:
  39    - "results" maps registers to the instructions that produced them;
  40    - "uses" maps registers to the instructions that use them.
  41    In addition:
  42    - code_stores contains the latest store nodes emitted so far
  43    - code_loads contains all load nodes emitted since the last store
  44    - code_checkbounds contains the latest checkbound node not matched
  45      by a subsequent load or store. *)
  46
  47 let code_results = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t)
  48 let code_uses = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t)
  49 let code_stores = ref ([] : code_dag_node list)
  50 let code_loads = ref ([] : code_dag_node list)
  51 let code_checkbounds = ref ([] : code_dag_node list)
  52
  53 let clear_code_dag () =
  54   Hashtbl.clear code_results;
  55   Hashtbl.clear code_uses;
  56   code_stores := [];
  57   code_loads := [];
  58   code_checkbounds := []
  59
  60 (* Add an edge to the code DAG *)
  61
  62 let add_edge ancestor son delay =
  63   ancestor.sons <- (son, delay) :: ancestor.sons;
  64   son.ancestors <- son.ancestors + 1
  65
  66 let add_edge_after son ancestor = add_edge ancestor son 0
  67
  68 (* Compute length of longest path to a result.
  69    For leafs of the DAG, see whether their result is used in the instruction
  70    immediately following the basic block (a "critical" output). *)
  71
  72 let is_critical critical_outputs results =
  73   try
  74     for i = 0 to Array.length results - 1 do
  75       let r = results.(i).loc in
  76       for j = 0 to Array.length critical_outputs - 1 do
  77         if critical_outputs.(j).loc = r then raise Exit
  78       done
  79     done;
  80     false
  81   with Exit ->
  82     true
  83
  84 let rec longest_path critical_outputs node =
  85   if node.length < 0 then begin
  86     match node.sons with
  87       [] ->
  88         node.length <-
  89           if is_critical critical_outputs node.instr.res
  90           || node.instr.desc = Lreloadretaddr (* alway critical *)
  91           then node.delay
  92           else 0
  93     | sons ->
  94         node.length <-
  95           List.fold_left
  96             (fun len (son, delay) ->
  97               max len (longest_path critical_outputs son + delay))
  98             0 sons
  99   end;
 100   node.length
 101
 102 (* Remove an instruction from the ready queue *)
 103
 104 let rec remove_instr node = function
 105     [] -> []
 106   | instr :: rem ->
 107       if instr == node then rem else instr :: remove_instr node rem
 108
 109 (* We treat Lreloadretaddr as a word-sized load *)
 110
 111 let some_load = (Iload(Cmm.Word, Arch.identity_addressing))
 112
 113 (* The generic scheduler *)
 114
 115 class virtual scheduler_generic = object (self)
 116
 117 (* Determine whether an operation ends a basic block or not.
 118    Can be overriden for some processors to signal specific instructions
 119    that terminate a basic block. *)
 120
 121 method oper_in_basic_block = function
 122     Icall_ind -> false
 123   | Icall_imm _ -> false
 124   | Itailcall_ind -> false
 125   | Itailcall_imm _ -> false
 126   | Iextcall _ -> false
 127   | Istackoffset _ -> false
 128   | Ialloc _ -> false
 129   | _ -> true
 130
 131 (* Determine whether an instruction ends a basic block or not *)
 132
 133 method private instr_in_basic_block instr =
 134   match instr.desc with
 135     Lop op -> self#oper_in_basic_block op
 136   | Lreloadretaddr -> true
 137   | _ -> false
 138
 139 (* Determine whether an operation is a memory store or a memory load.
 140    Can be overriden for some processors to signal specific
 141    load or store instructions (e.g. on the I386). *)
 142
 143 method is_store = function
 144     Istore(_, _) -> true
 145   | _ -> false
 146
 147 method is_load = function
 148     Iload(_, _) -> true
 149   | _ -> false
 150
 151 method is_checkbound = function
 152     Iintop Icheckbound -> true
 153   | Iintop_imm(Icheckbound, _) -> true
 154   | _ -> false
 155
 156 method private instr_is_store instr =
 157   match instr.desc with
 158     Lop op -> self#is_store op
 159   | _ -> false
 160
 161 method private instr_is_load instr =
 162   match instr.desc with
 163     Lop op -> self#is_load op
 164   | _ -> false
 165
 166 method private instr_is_checkbound instr =
 167   match instr.desc with
 168     Lop op -> self#is_checkbound op
 169   | _ -> false
 170
 171 (* Estimate the latency of an operation. *)
 172
 173 method virtual oper_latency : Mach.operation -> int
 174
 175 (* Estimate the latency of a Lreloadretaddr operation. *)
 176
 177 method reload_retaddr_latency = self#oper_latency some_load
 178
 179 (* Estimate the delay needed to evaluate an instruction *)
 180
 181 method private instr_latency instr =
 182   match instr.desc with
 183     Lop op -> self#oper_latency op
 184   | Lreloadretaddr -> self#reload_retaddr_latency
 185   | _ -> assert false
 186
 187 (* Estimate the number of cycles consumed by emitting an operation. *)
 188
 189 method virtual oper_issue_cycles : Mach.operation -> int
 190
 191 (* Estimate the number of cycles consumed by emitting a Lreloadretaddr. *)
 192
 193 method reload_retaddr_issue_cycles = self#oper_issue_cycles some_load
 194
 195 (* Estimate the number of cycles consumed by emitting an instruction. *)
 196
 197 method private instr_issue_cycles instr =
 198   match instr.desc with
 199     Lop op -> self#oper_issue_cycles op
 200   | Lreloadretaddr -> self#reload_retaddr_issue_cycles
 201   | _ -> assert false
 202
 203 (* Add an instruction to the code dag *)
 204
 205 method private add_instruction ready_queue instr =
 206   let delay = self#instr_latency instr in
 207   let node =
 208     { instr = instr;
 209       delay = delay;
 210       sons = [];
 211       date = 0;
 212       length = -1;
 213       ancestors = 0;
 214       emitted_ancestors = 0 } in
 215   (* Add edges from all instructions that define one of the registers used
 216      (RAW dependencies) *)
 217   for i = 0 to Array.length instr.arg - 1 do
 218     try
 219       let ancestor = Hashtbl.find code_results instr.arg.(i).loc in
 220       add_edge ancestor node ancestor.delay
 221     with Not_found ->
 222       ()
 223   done;
 224   (* Also add edges from all instructions that use one of the result regs
 225      of this instruction (WAR dependencies). *)
 226   for i = 0 to Array.length instr.res - 1 do
 227     let ancestors = Hashtbl.find_all code_uses instr.res.(i).loc in
 228     List.iter (add_edge_after node) ancestors
 229   done;
 230   (* Also add edges from all instructions that have already defined one
 231      of the results of this instruction (WAW dependencies). *)
 232   for i = 0 to Array.length instr.res - 1 do
 233     try
 234       let ancestor = Hashtbl.find code_results instr.res.(i).loc in
 235       add_edge ancestor node 0
 236     with Not_found ->
 237       ()
 238   done;
 239   (* If this is a load, add edges from the most recent store viewed so
 240      far (if any) and remember the load.  Also add edges from the most
 241      recent checkbound and forget that checkbound. *)
 242   if self#instr_is_load instr then begin
 243     List.iter (add_edge_after node) !code_stores;
 244     code_loads := node :: !code_loads;
 245     List.iter (add_edge_after node) !code_checkbounds;
 246     code_checkbounds := []
 247   end
 248   (* If this is a store, add edges from the most recent store,
 249      as well as all loads viewed since then, and also the most recent
 250      checkbound. Remember the store,
 251      discarding the previous stores, loads and checkbounds. *)
 252   else if self#instr_is_store instr then begin
 253     List.iter (add_edge_after node) !code_stores;
 254     List.iter (add_edge_after node) !code_loads;
 255     List.iter (add_edge_after node) !code_checkbounds;
 256     code_stores := [node];
 257     code_loads := [];
 258     code_checkbounds := []
 259   end
 260   else if self#instr_is_checkbound instr then begin
 261     code_checkbounds := [node]
 262   end;
 263   (* Remember the registers used and produced by this instruction *)
 264   for i = 0 to Array.length instr.res - 1 do
 265     Hashtbl.add code_results instr.res.(i).loc node
 266   done;
 267   for i = 0 to Array.length instr.arg - 1 do
 268     Hashtbl.add code_uses instr.arg.(i).loc node
 269   done;
 270   (* If this is a root instruction (all arguments already computed),
 271      add it to the ready queue *)
 272   if node.ancestors = 0 then node :: ready_queue else ready_queue
 273
 274 (* Given a list of instructions and a date, choose one or several
 275    that are ready to be computed (start date <= current date)
 276    and that we can emit in one cycle.  Favor instructions with
 277    maximal distance to result.  If we can't find any, return None.
 278    This does not take multiple issues into account, though. *)
 279
 280 method private ready_instruction date queue =
 281   let rec extract best = function
 282     [] ->
 283       if best == dummy_node then None else Some best
 284   | instr :: rem ->
 285       let new_best =
 286         if instr.date <= date && instr.length > best.length
 287         then instr else best in
 288       extract new_best rem in
 289   extract dummy_node queue
 290
 291 (* Schedule a basic block, adding its instructions in front of the given
 292    instruction sequence *)
 293
 294 method private reschedule ready_queue date cont =
 295   if ready_queue = [] then cont else begin
 296     match self#ready_instruction date ready_queue with
 297       None ->
 298         self#reschedule ready_queue (date + 1) cont
 299     | Some node ->
 300         (* Remove node from queue *)
 301         let new_queue = ref (remove_instr node ready_queue) in
 302         (* Update the start date and number of ancestors emitted of
 303            all descendents of this node. Enter those that become ready
 304            in the queue. *)
 305         let issue_cycles = self#instr_issue_cycles node.instr in
 306         List.iter
 307           (fun (son, delay) ->
 308             let completion_date = date + issue_cycles + delay - 1 in
 309             if son.date < completion_date then son.date <- completion_date;
 310             son.emitted_ancestors <- son.emitted_ancestors + 1;
 311             if son.emitted_ancestors = son.ancestors then
 312               new_queue := son :: !new_queue)
 313           node.sons;
 314         instr_cons node.instr.desc node.instr.arg node.instr.res
 315           (self#reschedule !new_queue (date + issue_cycles) cont)
 316   end
 317
 318 (* Entry point *)
 319 (* Don't bother to schedule for initialization code and the like. *)
 320
 321 method schedule_fundecl f =
 322
 323   let rec schedule i =
 324     match i.desc with
 325       Lend -> i
 326     | _ ->
 327         if self#instr_in_basic_block i then begin
 328           clear_code_dag();
 329           schedule_block [] i
 330         end else
 331           { i with next = schedule i.next }
 332
 333   and schedule_block ready_queue i =
 334     if self#instr_in_basic_block i then
 335       schedule_block (self#add_instruction ready_queue i) i.next
 336     else begin
 337       let critical_outputs =
 338         match i.desc with
 339           Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |]
 340         | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||]
 341         | Lreturn -> [||]
 342         | _ -> i.arg in
 343       List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue;
 344       self#reschedule ready_queue 0 (schedule i)
 345     end in
 346
 347   if f.fun_fast then begin
 348     let new_body = schedule f.fun_body in
 349     clear_code_dag();
 350     { fun_name = f.fun_name;
 351       fun_body = new_body;
 352       fun_fast = f.fun_fast }
 353   end else
 354     f
 355
 356 end