arch/bfd/util/bfd_eval.ml

   1 (*
   2  * Expression evaluation.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2001 Jason Hickey, Caltech
   8  *
   9  * This program is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU General Public License
  11  * as published by the Free Software Foundation; either version 2
  12  * of the License, or (at your option) any later version.
  13  *
  14  * This program is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with this program; if not, write to the Free Software
  21  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  *
  23  * Author: Jason Hickey
  24  * @email{jyh@cs.caltech.edu}
  25  * @end[license]
  26  *)
  27 open Format
  28
  29 open Debug
  30 open Symbol
  31
  32 open Fir_exn
  33 open Fir_pos
  34
  35 open Bfd
  36 open Bfd_env
  37 open Bfd_buf
  38 open Bfd_util
  39 open Bfd_state
  40
  41 module Pos = MakePos (struct let name = "Bfd_eval" end)
  42 open Pos
  43
  44 (************************************************************************
  45  * UTILITIES
  46  ************************************************************************)
  47
  48 (*
  49  * For expressions that cant be evaluated yet.
  50  *)
  51 exception CantEval
  52
  53 (*
  54  * Some int32 arithmetic.
  55  *)
  56 let shift_left i1 i2 =
  57    Int32.shift_left i1 (Int32.to_int i2)
  58
  59 let shift_right i1 i2 =
  60    Int32.shift_right i1 (Int32.to_int i2)
  61
  62 let shift_right_logical i1 i2 =
  63    Int32.shift_right_logical i1 (Int32.to_int i2)
  64
  65 let bfd_align i1 i2 =
  66    let i2 = Int32.pred i2 in
  67       Int32.logand (Int32.add i1 i2) (Int32.lognot i2)
  68
  69 (************************************************************************
  70  * LAZY EVALUATION
  71  ************************************************************************)
  72
  73 (*
  74  * Lazy evaluation doesn't try too hard.
  75  * Resolving to ValLabel, ValRelative is ok.
  76  *)
  77
  78 (*
  79  * Apply a unary expression.
  80  *)
  81 let rec lazy_unary venv op e =
  82    match eager_exp venv e with
  83       ValAbsolute i ->
  84          ValAbsolute (op i)
  85     | ValSection _
  86     | ValLabel _
  87     | ValRelative _
  88     | ValUndefined ->
  89          raise CantEval
  90
  91 (*
  92  * Apply a binary expression.
  93  * Evaluation is only allowed if the expressions
  94  * are absolute numbers.
  95  *)
  96 and lazy_binary venv op e1 e2 =
  97    match eager_exp venv e1, eager_exp venv e2 with
  98       ValAbsolute i1, ValAbsolute i2 ->
  99          ValAbsolute (op i1 i2)
 100     | _ ->
 101          raise CantEval
 102
 103 (*
 104  * For addition, it is also allowed to
 105  * add a constant to a relative expression.
 106  *)
 107 and lazy_binary_add venv op e1 e2 =
 108    match lazy_exp venv e1, eager_exp venv e2 with
 109       ValAbsolute i1, ValAbsolute i2 ->
 110          ValAbsolute (op i1 i2)
 111     | ValSection (sect, i1), ValAbsolute i2 ->
 112          ValSection (sect, op i1 i2)
 113     | ValLabel (v, i1), ValAbsolute i2 ->
 114          ValLabel (v, op i1 i2)
 115     | ValRelative (v1, v2, i1), ValAbsolute i2 ->
 116          ValRelative (v1, v2, op i1 i2)
 117     | _ ->
 118          raise CantEval
 119
 120 (*
 121  * For differences, evaluation can also be carried out if
 122  * the two expressions are both offsets into a section.
 123  *)
 124 and lazy_binary_sub venv op e1 e2 =
 125    match eager_exp venv e1, eager_exp venv e2 with
 126       ValAbsolute i1, ValAbsolute i2 ->
 127          ValAbsolute (op i1 i2)
 128     | ValSection (sect, i1), ValAbsolute i2 ->
 129          ValSection (sect, op i1 i2)
 130     | ValSection (sect1, i1), ValSection (sect2, i2)
 131       when Symbol.eq sect1 sect2 ->
 132          ValAbsolute (op i1 i2)
 133     | _ ->
 134          raise CantEval
 135
 136 (*
 137  * Relative addresses.
 138  *)
 139 and lazy_binary_rel venv op e l2 =
 140    match lazy_exp venv e with
 141       ValAbsolute i1 ->
 142          (match eager_label SymbolSet.empty venv l2 with
 143              ValAbsolute i2 ->
 144                 ValAbsolute (op i1 i2)
 145            | _ ->
 146                 raise CantEval)
 147     | ValSection (sect1, i1) ->
 148          (match eager_label SymbolSet.empty venv l2 with
 149              ValAbsolute i2 ->
 150                 ValAbsolute (op i1 i2)
 151            | ValSection (sect2, i2)
 152              when Symbol.eq sect1 sect2 ->
 153                 ValAbsolute (op i1 i2)
 154            | _ ->
 155                 raise CantEval)
 156     | ValLabel (l1, i1) ->
 157          ValRelative (l1, l2, i1)
 158     | _ ->
 159          raise CantEval
 160
 161 (*
 162  * Lazy evaluation is happy resolving to labels.
 163  *)
 164 and lazy_exp venv e =
 165    match e with
 166       ExpInt32 i ->
 167          ValAbsolute i
 168     | ExpLabel v ->
 169          ValLabel (v, Int32.zero)
 170     | ExpUMinus e ->
 171          lazy_unary venv Int32.neg e
 172     | ExpUNot e ->
 173          lazy_unary venv Int32.lognot e
 174     | ExpUAbs e ->
 175          lazy_unary venv Int32.abs e
 176     | ExpULog2 e ->
 177          lazy_unary venv log2 e
 178     | ExpUPow2 e ->
 179          lazy_unary venv pow2 e
 180     | ExpAdd (e1, e2) ->
 181          lazy_binary_add venv Int32.add e1 e2
 182     | ExpSub (e1, e2) ->
 183          lazy_binary_sub venv Int32.sub e1 e2
 184     | ExpRel (e, l) ->
 185          lazy_binary_rel venv Int32.sub e l
 186     | ExpMul (e1, e2) ->
 187          lazy_binary venv Int32.mul e1 e2
 188     | ExpDiv (e1, e2) ->
 189          lazy_binary venv Int32.div e1 e2
 190     | ExpSal (e1, e2) ->
 191          lazy_binary venv shift_left e1 e2
 192     | ExpSar (e1, e2) ->
 193          lazy_binary venv shift_right e1 e2
 194     | ExpShr (e1, e2) ->
 195          lazy_binary venv shift_right_logical e1 e2
 196     | ExpAnd (e1, e2) ->
 197          lazy_binary venv Int32.logand e1 e2
 198     | ExpOr  (e1, e2) ->
 199          lazy_binary venv Int32.logor e1 e2
 200     | ExpXor (e1, e2) ->
 201          lazy_binary venv Int32.logxor e1 e2
 202     | ExpAlign (e1, e2) ->
 203          lazy_binary venv bfd_align e1 e2
 204
 205 (************************************************************************
 206  * EAGER EVALUATION
 207  ************************************************************************)
 208
 209 (*
 210  * Eager evaluation tries harder.
 211  * It is _not_ acceptable to evaluate to
 212  * a ValLabel or ValRelative.
 213  *)
 214
 215 (*
 216  * Resolve the value of a variable.
 217  *)
 218 and eager_label vars venv v =
 219    let vars =
 220       if SymbolSet.mem vars v then
 221          raise (Invalid_argument ("Bfd_eval: recursive definition of symbol " ^ string_of_symbol v));
 222       SymbolSet.add vars v
 223    in
 224    let info =
 225       try venv_lookup venv v with
 226          Not_found ->
 227             let pos = var_exp_pos v in
 228             let pos = string_pos "eager_label" pos in
 229                raise (FirException (pos, UnboundVar v))
 230    in
 231       eager_value vars venv info.sym_value
 232
 233 (*
 234  * Try hard to resolve a value.
 235  *)
 236 and eager_value vars venv v =
 237    match v with
 238       ValAbsolute _
 239     | ValSection _ ->
 240          v
 241     | ValLabel (v, i2) ->
 242          (match eager_label vars venv v with
 243              ValAbsolute i1 ->
 244                 ValAbsolute (Int32.add i1 i2)
 245            | ValSection (sect, i1) ->
 246                 ValSection (sect, Int32.add i1 i2)
 247            | _ ->
 248                 raise CantEval)
 249     | ValRelative (v1, v2, i3) ->
 250          (match eager_label vars venv v1, eager_label vars venv v2 with
 251              ValAbsolute i1, ValAbsolute i2 ->
 252                 ValAbsolute (Int32.add (Int32.sub i1 i2) i3)
 253            | ValSection (sect, i1), ValAbsolute i2 ->
 254                 ValSection (sect, Int32.add (Int32.sub i1 i2) i3)
 255            | ValSection (sect1, i1), ValSection (sect2, i2)
 256              when Symbol.eq sect1 sect2 ->
 257                 ValAbsolute (Int32.add (Int32.sub i1 i2) i3)
 258            | _ ->
 259                 raise CantEval)
 260     | ValUndefined ->
 261          raise CantEval
 262
 263 (*
 264  * Eager evalution tries harder.
 265  * It never evaluates to ValLabel, ValRelative, or ValUndefined.
 266  *)
 267 and eager_exp venv e =
 268    eager_value SymbolSet.empty venv (lazy_exp venv e)
 269
 270 (************************************************************************
 271  * GLOBAL WRAPPERS
 272  ************************************************************************)
 273
 274 (*
 275  * Wrapper catches the Not_found case.
 276  *)
 277 let eval_eager_exp venv e =
 278    try eager_exp venv e with
 279       CantEval ->
 280          ValUndefined
 281
 282 let eval_eager_value venv v =
 283    try eager_value SymbolSet.empty venv v with
 284       CantEval ->
 285          ValUndefined
 286
 287 let eval_lazy_exp venv e =
 288    try lazy_exp venv e with
 289       CantEval ->
 290          ValUndefined
 291
 292 (*!
 293  * @docoff
 294  *
 295  * -*-
 296  * Local Variables:
 297  * Caml-master: "compile"
 298  * End:
 299  * -*-
 300  *)