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 let () =
  28   (* Parse command line arguments. *)
  29   let debug = ref false in
  30   let save_temps = ref false in
  31   let version () =
  32     printf "bitmatch-import-c %s" Bitmatch.version;
  33     exit 1
  34   in
  35   let cpp_args = ref [] in
  36   let cpp_arg2 name value =
  37     cpp_args := (name ^ value) :: !cpp_args
  38   in
  39
  40   let argspec = Arg.align [
  41     "--debug", Arg.Set debug,
  42       " Debug messages";
  43     "--version", Arg.Unit version,
  44       " Display version and exit";
  45     "-save-temps", Arg.Set save_temps,
  46       " Save temporary files";
  47     "-I", Arg.String (cpp_arg2 "-I"),
  48       "dir Specify extra include directory for cpp";
  49     "-D", Arg.String (cpp_arg2 "-D"),
  50       "name=value Define value in cpp";
  51     "-U", Arg.String (cpp_arg2 "-U"),
  52       "name Undefine value in cpp";
  53   ] in
  54
  55   let input_file = ref None in
  56   let anon_fun str =
  57     match !input_file with
  58     | None -> input_file := Some str
  59     | Some _ ->
  60         eprintf "bitmatch-import-c: only give a single input file\n";
  61         exit 1
  62   in
  63   let usage_msg = "\
  64
  65 bitmatch-import-c: Import C structures and constants and
  66   generate bitmatching functions from them.  Please see the
  67   manual page bitmatch-import-c(1) for more information.
  68
  69 OPTIONS" in
  70
  71   Arg.parse argspec anon_fun usage_msg;
  72
  73   let debug = !debug in
  74   let save_temps = !save_temps in
  75   let input_file =
  76     match !input_file with
  77     | Some f -> f
  78     | None ->
  79         eprintf "bitmatch-import-c: no input file specified\n";
  80         exit 1 in
  81   let cpp_args = List.rev !cpp_args in
  82
  83   (* Grab the file and pass it to the preprocessor, and then read the
  84    * C code into memory using CIL.
  85    *)
  86   msvcMode := false;
  87   Cil.initCIL ();
  88
  89   (* XXX Unavoidable tmp exploit here.  Fix? *)
  90   let tmp, delete_tmp =
  91     if not save_temps then (
  92       let tmp = Filename.temp_file (Filename.temp_dir_name) ".i" in
  93       tmp, fun () -> try Unix.unlink tmp with Unix.Unix_error _ -> ()
  94     ) else (
  95       let tmp = Filename.chop_extension input_file ^ ".i" in
  96       tmp, fun () -> (* -save-temps, so do nothing *) ()
  97     ) in
  98
  99   let cmd =
 100     sprintf "cpp %s -include bitmatch-import-prefix.h %s > %s"
 101       (String.concat " " (List.map Filename.quote cpp_args))
 102       (Filename.quote input_file) (Filename.quote tmp) in
 103   if debug then prerr_endline cmd;
 104   if Sys.command cmd <> 0 then (
 105     eprintf "%s: command failed\n" cmd;
 106     delete_tmp ();
 107     exit 1
 108   );
 109
 110   (* Why does Frontc.parse return a continuation ...? *)
 111   let file = (Frontc.parse tmp) () in
 112   delete_tmp ();
 113
 114   (* Find out which structures, #defines, etc. are to be imported.
 115    * (cf. the macros in bitmatch-import-prefix.h)
 116    *)
 117   let constants =
 118     List.filter_map (
 119       function
 120       | GVar ({vname = vname; vtype = vtype},
 121               { init = Some (SingleInit vinit) },
 122               loc)
 123           when String.starts_with vname "__bitmatch_constant_" ->
 124           let vname = String.sub vname 20 (String.length vname - 20) in
 125
 126           (* Do constant folding on the initializer and then calculate
 127            * its compile-time value.
 128            *)
 129           let vinit =
 130             match isInteger (constFold true vinit) with
 131             | Some i -> i
 132             | None ->
 133                 Errormsg.error
 134                   "%a: non-constant initializer: %a" d_loc loc d_exp vinit;
 135                 -1L in
 136
 137           Some (vname, vinit, loc)
 138       | _ -> None
 139     ) file.globals in
 140   let structs =
 141     List.filter_map (
 142       function
 143       | GType ({tname = tname; ttype = ttype}, loc)
 144           when String.starts_with tname "__bitmatch_import_" ->
 145           let tname = String.sub tname 18 (String.length tname - 18) in
 146           Some (tname, ttype, loc)
 147       | _ -> None
 148     ) file.globals in
 149
 150   if !Errormsg.hadErrors then exit 1;
 151
 152   (* If debugging, print out the imports. *)
 153   if debug then (
 154     List.iter (
 155       fun (vname, vinit, loc) ->
 156         Errormsg.log "%a: import %s as constant 0x%LX\n" d_loc loc vname vinit;
 157     ) constants;
 158     List.iter (
 159       fun (tname, ttype, loc) ->
 160         Errormsg.log "%a: import %s as %a\n" d_loc loc tname d_type ttype;
 161     ) structs;
 162   );
 163
 164   (* Output constants. *)
 165   List.iter (
 166     fun (vname, vinit, loc) ->
 167       printf "let %s = 0x%LX\n" vname vinit
 168   ) constants;
 169
 170   (* Output structures. *)
 171   List.iter (
 172     fun (tname, ttype, loc) ->
 173       (* Uncomment the next line if you want to really print the
 174        * complete CIL structure of the type (for debugging etc.).
 175        * The ASTs printed here are usually quite large.
 176        *)
 177       (*Errormsg.log "%a: %s %a\n" d_loc loc tname d_plaintype ttype;*)
 178
 179       (* Match on the type of this structure, and from it generate
 180        * a single parsing function.
 181        *)
 182       match ttype with
 183         (* struct or union *)
 184       | TComp ({ cdefined = true; cname = cname }, _) ->
 185           printf "let %s_of_bitstring bits =\n" tname;
 186           printf "  bitmatch bits with\n";
 187           printf "  | {\n";
 188           (*output_struct [] NoOffset None ttype;*)
 189           printf "    } ->\n";
 190           printf "    Some (...)\n";
 191           printf "  | { _ } -> None\n\n"
 192
 193       (* An undefined struct or union -- means one which was only ever
 194        * defined with 'struct foo;'.  This is an error.
 195        *)
 196       | TComp ({ cdefined = false; cname = cname }, _) ->
 197           Errormsg.error
 198             "%a: struct or union has no definition: %s" d_loc loc cname
 199
 200       (* Types which are not allowed, eg. void, int, arrays. *)
 201       | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _
 202       | TNamed _ | TBuiltin_va_list _ ->
 203           Errormsg.error
 204             "%a: not a struct or union: %a" d_loc loc d_type ttype
 205
 206       (* Types which we might implement in the future.
 207        * For enum we should probably split out enums separately
 208        * from structs above, since enums are more like constants.
 209        *)
 210       | TEnum ({ ename = ename }, _) ->
 211           Errormsg.unimp "%a: %a" d_loc loc d_type ttype
 212 (*
 213       let rec to_fields names offset endian = function
 214           (* Some types contain attributes to indicate their
 215            * endianness.  See many examples from <linux/types.h>.
 216            *)
 217         | (TNamed ({ tname = tname;
 218                      ttype = TNamed (_, attrs) },
 219                    _) as t)
 220             when hasAttribute "bitwise" attrs ->
 221             let endian =
 222               if String.starts_with tname "__le" then
 223                 Some Bitmatch.LittleEndian
 224               else if String.starts_with tname "__be" then
 225                 Some Bitmatch.BigEndian
 226               else (
 227                 Errormsg.warn "%a: unknown bitwise attribute typename: %s\n"
 228                   d_loc loc tname;
 229                 endian
 230               ) in
 231             to_fields names offset endian (unrollType t)
 232
 233         (* See into named types. *)
 234         | (TNamed _ as t) ->
 235             to_fields names offset endian (unrollType t)
 236
 237         (* struct or union *)
 238         | TComp ({ cdefined = true; cfields = cfields }, _) ->
 239             let cfields =
 240               List.map (
 241                 fun ({ fname = fname; ftype = ftype } as finfo) ->
 242                   let offset = Field (finfo, offset) in
 243                   let names = fname :: names in
 244                   to_fields names offset endian ftype
 245               ) cfields in
 246             List.flatten cfields
 247
 248         (* int array with constant length *)
 249         | TArray (basetype, (Some _ as len), _)
 250             when isIntegralType basetype ->
 251             let len = lenOfArray len in
 252             let bitsoffset, totalwidth = bitsOffset ttype offset in
 253             let bitswidth = totalwidth / len (* of the element *) in
 254             (*if debug then (
 255               let name = String.concat "." (List.rev names) in
 256               Errormsg.log "%s: int array: %d, %d, len %d\n"
 257                 name bitsoffset bitswidth len
 258             );*)
 259             let basetype = unrollType basetype in
 260             let ikind =
 261               match basetype with
 262               | TInt (ikind, _) -> ikind
 263               | t ->
 264                   Errormsg.unimp "%a: unhandled type: %a" d_loc loc d_type t;
 265                   IInt in
 266             let field =
 267               to_int_field "" bitsoffset bitswidth ikind endian in
 268             let fname = String.concat "_" (List.rev names) in
 269             let byteoffset = bitsoffset lsr 3 in
 270             let bytetotalwidth = totalwidth lsr 3 in
 271             printf "--> array %s: byteoffset=%d bytetotalwidth=%d len=%d\n"
 272               fname byteoffset bytetotalwidth len (* field *);
 273             []
 274
 275         (* basic integer type *)
 276         | TInt (ikind, _) ->
 277             let bitsoffset, bitswidth = bitsOffset ttype offset in
 278             (*if debug then (
 279               let name = String.concat "." (List.rev names) in
 280               Errormsg.log "%s: int: %d, %d\n" name bitsoffset bitswidth
 281             );*)
 282             let fname = String.concat "_" (List.rev names) in
 283             let field =
 284               to_int_field fname bitsoffset bitswidth ikind endian in
 285             [field]
 286
 287         (* a pointer - in this mapping we assume this is an address
 288          * (endianness and wordsize come from function parameters),
 289          * in other words we DON'T try to follow pointers, we just
 290          * note that they are there.
 291          *)
 292         | TPtr _ ->
 293             let bitsoffset, bitswidth = bitsOffset ttype offset in
 294             let fname = String.concat "_" (List.rev names) in
 295             printf "--> pointer %s: bitsoffset=%d bitswidth=%d\n"
 296               fname bitsoffset bitswidth;
 297             []
 298
 299         | t ->
 300             Errormsg.unimp "to_fields: %a: unhandled type: %a"
 301               d_loc loc d_type t;
 302             []
 303
 304       and to_int_field fname bitsoffset bitswidth ikind endian =
 305         let byteoffset = bitsoffset lsr 3 in
 306         let bytewidth = bitswidth lsr 3 in
 307         let signed = isSigned ikind in
 308
 309         if bitsoffset land 7 = 0 && bitswidth land 7 = 0 then (
 310           (* Not a bitfield. *)
 311           match bitswidth with
 312           | 8 ->
 313               printf "--> byte %s: byteoffset=%d bytewidth=%d signed=%b\n"
 314                 fname byteoffset bytewidth signed
 315           | 16 ->
 316               printf "--> short %s: byteoffset=%d bytewidth=%d signed=%b endian=%s\n"
 317                 fname byteoffset bytewidth signed (Option.map_default Bitmatch.string_of_endian "None" endian)
 318           | 32 ->
 319               printf "--> int %s: byteoffset=%d bytewidth=%d signed=%b endian=%s\n"
 320                 fname byteoffset bytewidth signed (Option.map_default Bitmatch.string_of_endian "None" endian)
 321           | 64 ->
 322               printf "--> long %s: byteoffset=%d bytewidth=%d signed=%b endian=%s\n"
 323                 fname byteoffset bytewidth signed (Option.map_default Bitmatch.string_of_endian "None" endian)
 324           | _ ->
 325               Errormsg.unimp "%s: unhandled integer width: %d bits"
 326                 fname bitswidth
 327         ) else (
 328           (* It's a bitfield if either the offset or width isn't
 329            * byte-aligned.
 330            *)
 331           let bitsoffset = bitsoffset land 7 in
 332           printf "--> bitfield %s: byteoffset=%d bytewidth=%d signed=%b endian=%s bitsoffset=%d bitswidth=%d\n"
 333             fname byteoffset bytewidth
 334             signed (Option.map_default Bitmatch.string_of_endian "None" endian) bitsoffset bitswidth
 335         )
 336       in
 337 *)
 338   ) structs;
 339
 340   if !Errormsg.hadErrors then exit 1;
 341
 342   exit 0