l4/pkg/ocaml/contrib/asmcomp/liveness.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: liveness.ml 7812 2007-01-29 12:11:18Z xleroy $ *)
  14
  15 (* Liveness analysis.
  16    Annotate mach code with the set of regs live at each point. *)
  17
  18 open Mach
  19
  20 let live_at_exit = ref []
  21 let find_live_at_exit k =
  22   try
  23     List.assoc k !live_at_exit
  24   with
  25   | Not_found -> Misc.fatal_error "Spill.find_live_at_exit"
  26
  27 let live_at_break = ref Reg.Set.empty
  28 let live_at_raise = ref Reg.Set.empty
  29
  30 let rec live i finally =
  31   (* finally is the set of registers live after execution of the
  32      instruction sequence.
  33      The result of the function is the set of registers live just
  34      before the instruction sequence.
  35      The instruction i is annotated by the set of registers live across
  36      the instruction. *)
  37   match i.desc with
  38     Iend ->
  39       i.live <- finally;
  40       finally
  41   | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
  42       (* i.live remains empty since no regs are live across *)
  43       Reg.set_of_array i.arg
  44   | Iifthenelse(test, ifso, ifnot) ->
  45       let at_join = live i.next finally in
  46       let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in
  47       i.live <- at_fork;
  48       Reg.add_set_array at_fork i.arg
  49   | Iswitch(index, cases) ->
  50       let at_join = live i.next finally in
  51       let at_fork = ref Reg.Set.empty in
  52       for i = 0 to Array.length cases - 1 do
  53         at_fork := Reg.Set.union !at_fork (live cases.(i) at_join)
  54       done;
  55       i.live <- !at_fork;
  56       Reg.add_set_array !at_fork i.arg
  57   | Iloop(body) ->
  58       let at_top = ref Reg.Set.empty in
  59       (* Yes, there are better algorithms, but we'll just iterate till
  60          reaching a fixpoint. *)
  61       begin try
  62         while true do
  63           let new_at_top = Reg.Set.union !at_top (live body !at_top) in
  64           if Reg.Set.equal !at_top new_at_top then raise Exit;
  65           at_top := new_at_top
  66         done
  67       with Exit -> ()
  68       end;
  69       i.live <- !at_top;
  70       !at_top
  71   | Icatch(nfail, body, handler) ->
  72       let at_join = live i.next finally in
  73       let before_handler = live handler at_join in
  74       let before_body =
  75           live_at_exit := (nfail,before_handler) :: !live_at_exit ;
  76           let before_body = live body at_join in
  77           live_at_exit := List.tl !live_at_exit ;
  78           before_body in
  79       i.live <- before_body;
  80       before_body
  81   | Iexit nfail ->
  82       let this_live = find_live_at_exit nfail in
  83       i.live <- this_live ;
  84       this_live
  85   | Itrywith(body, handler) ->
  86       let at_join = live i.next finally in
  87       let before_handler = live handler at_join in
  88       let saved_live_at_raise = !live_at_raise in
  89       live_at_raise := Reg.Set.remove Proc.loc_exn_bucket before_handler;
  90       let before_body = live body at_join in
  91       live_at_raise := saved_live_at_raise;
  92       i.live <- before_body;
  93       before_body
  94   | Iraise ->
  95       (* i.live remains empty since no regs are live across *)
  96       Reg.add_set_array !live_at_raise i.arg
  97   | _ ->
  98       let across_after = Reg.diff_set_array (live i.next finally) i.res in
  99       let across =
 100         match i.desc with
 101           Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _)
 102         | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
 103             (* The function call may raise an exception, branching to the
 104                nearest enclosing try ... with. Similarly for bounds checks.
 105                Hence, everything that must be live at the beginning of
 106                the exception handler must also be live across this instr. *)
 107              Reg.Set.union across_after !live_at_raise
 108          | _ ->
 109              across_after in
 110       i.live <- across;
 111       Reg.add_set_array across i.arg
 112
 113 let fundecl ppf f =
 114   let initially_live = live f.fun_body Reg.Set.empty in
 115   (* Sanity check: only function parameters can be live at entrypoint *)
 116   let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in
 117   if not (Reg.Set.is_empty wrong_live) then begin
 118     Format.fprintf ppf "%a@." Printmach.regset wrong_live;
 119     Misc.fatal_error "Liveness.fundecl"
 120   end