cil-tools/bitmatch_import_c.ml

   1 (* Import a C header file.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22 open ExtList
  23 open ExtString
  24
  25 open Cil
  26
  27 module P = Bitmatch_persistent
  28
  29 let () =
  30   (* Parse command line arguments. *)
  31   let debug = ref false in
  32   let save_temps = ref false in
  33   let version () =
  34     printf "bitmatch-import-c %s" Bitmatch.version;
  35     exit 1
  36   in
  37   let cpp_args = ref [] in
  38   let cpp_arg2 name value =
  39     cpp_args := (name ^ value) :: !cpp_args
  40   in
  41
  42   let argspec = Arg.align [
  43     "--debug", Arg.Set debug,
  44       " Debug messages";
  45     "--version", Arg.Unit version,
  46       " Display version and exit";
  47     "-save-temps", Arg.Set save_temps,
  48       " Save temporary files";
  49     "-I", Arg.String (cpp_arg2 "-I"),
  50       "dir Specify extra include directory for cpp";
  51     "-D", Arg.String (cpp_arg2 "-D"),
  52       "name=value Define value in cpp";
  53     "-U", Arg.String (cpp_arg2 "-U"),
  54       "name Undefine value in cpp";
  55   ] in
  56
  57   let input_file = ref None in
  58   let anon_fun str =
  59     match !input_file with
  60     | None -> input_file := Some str
  61     | Some _ ->
  62         eprintf "bitmatch-import-c: only give a single input file\n";
  63         exit 1
  64   in
  65   let usage_msg = "\
  66
  67 bitmatch-import-c: Import C structures and constants and
  68   generate bitmatching functions from them.  Please see the
  69   manual page bitmatch-import-c(1) for more information.
  70
  71 OPTIONS" in
  72
  73   Arg.parse argspec anon_fun usage_msg;
  74
  75   let debug = !debug in
  76   let save_temps = !save_temps in
  77   let input_file =
  78     match !input_file with
  79     | Some f -> f
  80     | None ->
  81         eprintf "bitmatch-import-c: no input file specified\n";
  82         exit 1 in
  83   let cpp_args = List.rev !cpp_args in
  84
  85   (* Grab the file and pass it to the preprocessor, and then read the
  86    * C code into memory using CIL.
  87    *)
  88   msvcMode := false;
  89   Cil.initCIL ();
  90
  91   (* XXX Unavoidable tmp exploit here.  Fix? *)
  92   let tmp, delete_tmp =
  93     if not save_temps then (
  94       let tmp = Filename.temp_file (Filename.temp_dir_name) ".i" in
  95       tmp, fun () -> try Unix.unlink tmp with Unix.Unix_error _ -> ()
  96     ) else (
  97       let tmp = Filename.chop_extension input_file ^ ".i" in
  98       tmp, fun () -> (* -save-temps, so do nothing *) ()
  99     ) in
 100
 101   let cmd =
 102     sprintf "cpp %s -include bitmatch-import-prefix.h %s > %s"
 103       (String.concat " " (List.map Filename.quote cpp_args))
 104       (Filename.quote input_file) (Filename.quote tmp) in
 105   if debug then prerr_endline cmd;
 106   if Sys.command cmd <> 0 then (
 107     eprintf "%s: command failed\n" cmd;
 108     delete_tmp ();
 109     exit 1
 110   );
 111
 112   (* Why does Frontc.parse return a continuation ...? *)
 113   let file = (Frontc.parse tmp) () in
 114   delete_tmp ();
 115
 116   (* Find out which structures, #defines, etc. are to be imported.
 117    * (cf. the macros in bitmatch-import-prefix.h)
 118    *)
 119   let constants =
 120     List.filter_map (
 121       function
 122       | GVar ({vname = vname; vtype = vtype},
 123               { init = Some (SingleInit vinit) },
 124               loc)
 125           when String.starts_with vname "__bitmatch_constant_" ->
 126           let vname = String.sub vname 20 (String.length vname - 20) in
 127
 128           (* Do constant folding on the initializer and then calculate
 129            * its compile-time value.
 130            *)
 131           let vinit =
 132             match isInteger (constFold true vinit) with
 133             | Some i -> i
 134             | None ->
 135                 Errormsg.error
 136                   "%a: non-constant initializer: %a" d_loc loc d_exp vinit;
 137                 -1L in
 138
 139           Some (vname, vinit, loc)
 140       | _ -> None
 141     ) file.globals in
 142   let structs =
 143     List.filter_map (
 144       function
 145       | GType ({tname = tname; ttype = ttype}, loc)
 146           when String.starts_with tname "__bitmatch_import_" ->
 147           let tname = String.sub tname 18 (String.length tname - 18) in
 148           Some (tname, ttype, loc)
 149       | _ -> None
 150     ) file.globals in
 151
 152   if !Errormsg.hadErrors then exit 1;
 153
 154   (* If debugging, print out the imports. *)
 155   if debug then (
 156     List.iter (
 157       fun (vname, vinit, loc) ->
 158         Errormsg.log "%a: import %s as constant 0x%LX\n" d_loc loc vname vinit;
 159     ) constants;
 160     List.iter (
 161       fun (tname, ttype, loc) ->
 162         Errormsg.log "%a: import %s as %a\n" d_loc loc tname d_type ttype;
 163     ) structs;
 164   );
 165
 166 (*
 167   (* Output constants.
 168    * XXX Disabled at the moment until we work out where to put them XXX
 169    *)
 170   List.iter (
 171     fun (vname, vinit, loc) ->
 172       printf "let %s = 0x%LX\n" vname vinit
 173   ) constants;
 174 *)
 175
 176   (* Output structures. *)
 177   List.iter (
 178     fun (tname, ttype, loc) ->
 179       (* Uncomment the next line if you want to really print the
 180        * complete CIL structure of the type (for debugging etc.).
 181        * The ASTs printed here are usually quite large.
 182        *)
 183       (*Errormsg.log "%a: %s %a\n" d_loc loc tname d_plaintype ttype;*)
 184
 185       (* Recursive function to generate a persistent pattern from a
 186        * C struct or union.  Quite a few limitations at the moment:
 187        *   (1) Structure elements must be in order.
 188        *   (2) Doesn't really work with unions [XXX].
 189        *
 190        * Parameters:
 191        *   ?names   List of names of parent structs.  Used in the
 192        *              recursive case for nested structs.
 193        *   ?offset  Offset of struct within parent, usually NoOffset.  Used
 194        *              in the recursive case for nested structs.
 195        *   ?endian  Inherited endianness, usually None.  Used for C
 196        *                __attribute__((bitwise)).
 197        *   ttype    CIL type of struct.
 198        * Returns:
 199        *   pattern  A bitmatch persistent pattern.
 200        *)
 201       let rec pattern_of_struct ?(names=[]) ?(offset=NoOffset) ?(endian=None)
 202           ttype =
 203         match ttype with
 204         (* Some types contain attributes to indicate their
 205          * endianness.  See many examples from <linux/types.h>.
 206          *)
 207         | (TNamed ({ tname = tname;
 208                      ttype = TNamed (_, attrs) },
 209                    _) as t)
 210             when hasAttribute "bitwise" attrs ->
 211             let endian =
 212               if String.starts_with tname "__le" then
 213                 Some Bitmatch.LittleEndian
 214               else if String.starts_with tname "__be" then
 215                 Some Bitmatch.BigEndian
 216               else (
 217                 Errormsg.warn "%a: unknown bitwise attribute typename: %s\n"
 218                   d_loc loc tname;
 219                 endian
 220               ) in
 221             pattern_of_struct ~names ~offset ~endian (unrollType t)
 222
 223         (* See into named types. *)
 224         | (TNamed _ as t) ->
 225             pattern_of_struct ~names ~offset ~endian (unrollType t)
 226
 227         (* struct or union *)
 228         | TComp ({ cdefined = true; cfields = cfields }, _) ->
 229             let cfields =
 230               List.map (
 231                 fun ({ fname = fname; ftype = ftype } as finfo) ->
 232                   let offset = Field (finfo, offset) in
 233                   let names = fname :: names in
 234                   pattern_of_struct ~names ~offset ~endian ftype
 235               ) cfields in
 236             List.flatten cfields
 237
 238         (* int array with constant length *)
 239         | TArray (basetype, (Some _ as len), _) when isIntegralType basetype ->
 240             let nr_elems = lenOfArray len in
 241             let bitsoffset, totalwidth = bitsOffset ttype offset in
 242             let bitswidth = totalwidth / nr_elems (* of the element *) in
 243             let basetype = unrollType basetype in
 244             let ikind =
 245               match basetype with
 246               | TInt (ikind, _) -> ikind
 247               | t ->
 248                   Errormsg.unimp "%a: unhandled type: %a" d_loc loc d_type t;
 249                   IInt in
 250             let fname = String.concat "_" (List.rev names) in
 251
 252             (* If the base type is 8 bits then we always translate this to
 253              * a string (whether the C type is signed or unsigned).  There
 254              * is no endianness in bytes so ignore that.
 255              *)
 256             if bitswidth = 8 then
 257               [pattern_field_of_string fname bitsoffset nr_elems]
 258             else (
 259               (* XXX Realistically we don't handle arrays well at
 260                * the moment.  Perhaps we should give up and match
 261                * this to a bitstring?
 262                *)
 263               let signed = isSigned ikind in
 264               if debug then
 265                 eprintf "--> array %s: nr_elems=%d signed=%b\n"
 266                   fname nr_elems signed;
 267               [] (* XXX *)
 268             )
 269
 270         (* basic integer type *)
 271         | TInt (ikind, _) ->
 272             let bitsoffset, bitswidth = bitsOffset ttype offset in
 273             (*if debug then (
 274               let name = String.concat "." (List.rev names) in
 275               Errormsg.log "%s: int: %d, %d\n" name bitsoffset bitswidth
 276             );*)
 277             let fname = String.concat "_" (List.rev names) in
 278             let field =
 279               pattern_field_of_int fname bitsoffset bitswidth ikind endian in
 280             [field]
 281
 282         (* a pointer - in this mapping we assume this is an address
 283          * (endianness and wordsize come from function parameters),
 284          * in other words we DON'T try to follow pointers, we just
 285          * note that they are there.
 286          *)
 287         | TPtr _ ->
 288             let bitsoffset, bitswidth = bitsOffset ttype offset in
 289             let fname = String.concat "_" (List.rev names) in
 290             if debug then
 291               eprintf "--> pointer %s: bitsoffset=%d bitswidth=%d\n"
 292                 fname bitsoffset bitswidth;
 293             [] (* XXX *)
 294
 295         | t ->
 296             Errormsg.warn "pattern_of_struct: %a: unhandled type: %a"
 297               d_loc loc d_type t;
 298             []
 299
 300       (* Convert a single int field into a pattern field.
 301        * Could be a bitfield, byte, short, etc.
 302        *)
 303       and pattern_field_of_int fname bitsoffset bitswidth ikind endian =
 304         let signed = isSigned ikind in
 305         let _loc = camlp4_loc_of_cil_loc loc in
 306
 307         let field = P.create_pattern_field _loc in
 308         let field = P.set_lident_patt field fname in
 309         let field = P.set_type_int field in
 310         let field = P.set_length_int field bitswidth in
 311         let field = P.set_offset_int field bitsoffset in
 312         let field = P.set_signed field signed in
 313         let field =
 314           match endian with
 315           | Some endian -> P.set_endian field endian
 316           | None -> P.set_endian field Bitmatch.NativeEndian in
 317
 318         field
 319
 320       and pattern_field_of_string fname bitsoffset nr_elems =
 321         let _loc = camlp4_loc_of_cil_loc loc in
 322         let field = P.create_pattern_field _loc in
 323         let field = P.set_lident_patt field fname in
 324         let field = P.set_type_string field in
 325         let field = P.set_length_int field (nr_elems*8) in
 326         let field = P.set_offset_int field bitsoffset in
 327         field
 328
 329       (* Convert a CIL location into a camlp4 location.  Grrr these
 330        * should be compatible!
 331        *)
 332       and camlp4_loc_of_cil_loc loc =
 333         let _loc = Camlp4.PreCast.Syntax.Ast.Loc.mk loc.file in
 334         Camlp4.PreCast.Syntax.Ast.Loc.move_line loc.line _loc
 335       in
 336
 337       (* Match on the type of this structure, and from it generate
 338        * a single parsing function.
 339        *)
 340       match ttype with
 341       (* struct or union *)
 342       | TComp ({ cdefined = true; cname = cname }, _) ->
 343           let pattern = pattern_of_struct ttype in
 344           let named_pattern = cname, P.Pattern pattern in
 345           P.named_to_channel stdout named_pattern
 346
 347       (* An undefined struct or union -- means one which was only ever
 348        * defined with 'struct foo;'.  This is an error.
 349        *)
 350       | TComp ({ cdefined = false; cname = cname }, _) ->
 351           Errormsg.error
 352             "%a: struct or union has no definition: %s" d_loc loc cname
 353
 354       (* Types which are not allowed, eg. void, int, arrays. *)
 355       | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
 356       | TNamed _ | TBuiltin_va_list _ ->
 357           Errormsg.error
 358             "%a: not a struct or union: %a" d_loc loc d_type ttype
 359
 360       (* Types which we might implement in the future.
 361        * For enum we should probably split out enums separately
 362        * from structs above, since enums are more like constants.
 363        *)
 364       | TEnum ({ ename = ename }, _) ->
 365           Errormsg.unimp "%a: %a" d_loc loc d_type ttype
 366
 367   ) structs;
 368
 369   if !Errormsg.hadErrors then exit 1;
 370
 371   exit 0