parsing_cocci/type_infer.ml

   1 (*
   2  * Copyright 2010, INRIA, University of Copenhagen
   3  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
   4  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   5  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   6  * This file is part of Coccinelle.
   7  *
   8  * Coccinelle is free software: you can redistribute it and/or modify
   9  * it under the terms of the GNU General Public License as published by
  10  * the Free Software Foundation, according to version 2 of the License.
  11  *
  12  * Coccinelle is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  19  *
  20  * The authors reserve the right to distribute this or future versions of
  21  * Coccinelle under other licenses.
  22  *)
  23
  24
  25 module T = Type_cocci
  26 module Ast = Ast_cocci
  27 module Ast0 = Ast0_cocci
  28 module V0 = Visitor_ast0
  29 module VT0 = Visitor_ast0_types
  30
  31 (* Type inference:
  32 Just propagates information based on declarations.  Could try to infer
  33 more precise information about expression metavariables, but not sure it is
  34 worth it.  The most obvious goal is to distinguish between test expressions
  35 that have pointer, integer, and boolean type when matching isomorphisms,
  36 but perhaps other needs will become apparent. *)
  37
  38 (* "functions" that return a boolean value *)
  39 let bool_functions = ["likely";"unlikely"]
  40
  41 let err wrapped ty s =
  42   T.typeC ty; Format.print_newline();
  43   failwith (Printf.sprintf "line %d: %s" (Ast0.get_line wrapped) s)
  44
  45 type id = Id of string | Meta of Ast.meta_name
  46
  47 let int_type = T.BaseType(T.IntType)
  48 let bool_type = T.BaseType(T.BoolType)
  49 let char_type = T.BaseType(T.CharType)
  50 let float_type = T.BaseType(T.FloatType)
  51
  52 let rec lub_type t1 t2 =
  53   match (t1,t2) with
  54     (None,None) -> None
  55   | (None,Some t) -> t2
  56   | (Some t,None) -> t1
  57   | (Some t1,Some t2) ->
  58       let rec loop = function
  59           (T.Unknown,t2) -> t2
  60         | (t1,T.Unknown) -> t1
  61         | (T.ConstVol(cv1,ty1),T.ConstVol(cv2,ty2)) when cv1 = cv2 ->
  62             T.ConstVol(cv1,loop(ty1,ty2))
  63
  64         (* pad: in pointer arithmetic, as in ptr+1, the lub must be ptr *)
  65         | (T.Pointer(ty1),T.Pointer(ty2)) ->
  66             T.Pointer(loop(ty1,ty2))
  67         | (ty1,T.Pointer(ty2)) -> T.Pointer(ty2)
  68         | (T.Pointer(ty1),ty2) -> T.Pointer(ty1)
  69
  70         | (T.Array(ty1),T.Array(ty2)) -> T.Array(loop(ty1,ty2))
  71         | (T.TypeName(s1),t2) -> t2
  72         | (t1,T.TypeName(s1)) -> t1
  73         | (t1,_) -> t1 in (* arbitrarily pick the first, assume type correct *)
  74       Some (loop (t1,t2))
  75
  76 let lub_envs envs =
  77   List.fold_left
  78     (function acc ->
  79       function env ->
  80         List.fold_left
  81           (function acc ->
  82             function (var,ty) ->
  83               let (relevant,irrelevant) =
  84                 List.partition (function (x,_) -> x = var) acc in
  85               match relevant with
  86                 [] -> (var,ty)::acc
  87               | [(x,ty1)] ->
  88                   (match lub_type (Some ty) (Some ty1) with
  89                     Some new_ty -> (var,new_ty)::irrelevant
  90                   | None -> irrelevant)
  91               | _ -> failwith "bad type environment")
  92           acc env)
  93     [] envs
  94
  95 let rec propagate_types env =
  96   let option_default = None in
  97   let bind x y = option_default in (* no generic way of combining types *)
  98
  99   let ident r k i =
 100     match Ast0.unwrap i with
 101       Ast0.Id(id) ->
 102         (try Some(List.assoc (Id(Ast0.unwrap_mcode id)) env)
 103         with Not_found -> None)
 104     | Ast0.MetaId(id,_,_) ->
 105         (try Some(List.assoc (Meta(Ast0.unwrap_mcode id)) env)
 106         with Not_found -> None)
 107     | _ -> k i in
 108
 109   let strip_cv = function
 110       Some (T.ConstVol(_,t)) -> Some t
 111     | t -> t in
 112
 113   (* types that might be integer types.  should char be allowed? *)
 114   let rec is_int_type = function
 115       T.BaseType(T.IntType)
 116     | T.BaseType(T.LongType)
 117     | T.BaseType(T.ShortType)
 118     | T.MetaType(_,_,_)
 119     | T.TypeName _
 120     | T.EnumName _
 121     | T.SignedT(_,None) -> true
 122     | T.SignedT(_,Some ty) -> is_int_type ty
 123     | _ -> false in
 124
 125   let expression r k e =
 126     let res = k e in
 127     let ty =
 128       match Ast0.unwrap e with
 129           (* pad: the type of id is set in the ident visitor *)
 130           Ast0.Ident(id) -> Ast0.set_type e res; res
 131         | Ast0.Constant(const) ->
 132             (match Ast0.unwrap_mcode const with
 133                  Ast.String(_) -> Some (T.Pointer(char_type))
 134                | Ast.Char(_) -> Some (char_type)
 135                | Ast.Int(_) -> Some (int_type)
 136                | Ast.Float(_) ->  Some (float_type))
 137               (* pad: note that in C can do either ptr(...) or ( *ptr)(...)
 138                * so I am not sure this code is enough.
 139                *)
 140         | Ast0.FunCall(fn,lp,args,rp) ->
 141             (match Ast0.get_type fn with
 142                  Some (T.FunctionPointer(ty)) -> Some ty
 143                |  _ ->
 144                     (match Ast0.unwrap fn with
 145                          Ast0.Ident(id) ->
 146                            (match Ast0.unwrap id with
 147                                 Ast0.Id(id) ->
 148                                   if List.mem (Ast0.unwrap_mcode id) bool_functions
 149                                   then Some(bool_type)
 150                                   else None
 151                               | _ -> None)
 152                        |        _ -> None))
 153         | Ast0.Assignment(exp1,op,exp2,_) ->
 154             let ty = lub_type (Ast0.get_type exp1) (Ast0.get_type exp2) in
 155               Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty
 156         | Ast0.CondExpr(exp1,why,Some exp2,colon,exp3) ->
 157             let ty = lub_type (Ast0.get_type exp2) (Ast0.get_type exp3) in
 158               Ast0.set_type exp2 ty; Ast0.set_type exp3 ty; ty
 159         | Ast0.CondExpr(exp1,why,None,colon,exp3) -> Ast0.get_type exp3
 160         | Ast0.Postfix(exp,op) | Ast0.Infix(exp,op) -> (* op is dec or inc *)
 161             Ast0.get_type exp
 162         | Ast0.Unary(exp,op) ->
 163             (match Ast0.unwrap_mcode op with
 164                  Ast.GetRef ->
 165                    (match Ast0.get_type exp with
 166                         None -> Some (T.Pointer(T.Unknown))
 167                       | Some t -> Some (T.Pointer(t)))
 168                | Ast.DeRef ->
 169                    (match Ast0.get_type exp with
 170                         Some (T.Pointer(t)) -> Some t
 171                       | _ -> None)
 172                | Ast.UnPlus -> Ast0.get_type exp
 173                | Ast.UnMinus -> Ast0.get_type exp
 174                | Ast.Tilde -> Ast0.get_type exp
 175                | Ast.Not -> Some(bool_type))
 176         | Ast0.Nested(exp1,op,exp2) -> failwith "nested in type inf not possible"
 177         | Ast0.Binary(exp1,op,exp2) ->
 178             let ty1 = Ast0.get_type exp1 in
 179             let ty2 = Ast0.get_type exp2 in
 180             let same_type = function
 181                 (None,None) -> Some (int_type)
 182
 183               (* pad: pointer arithmetic handling as in ptr+1 *)
 184               | (Some (T.Pointer ty1),Some ty2) when is_int_type ty2 ->
 185                   Some (T.Pointer ty1)
 186               | (Some ty1,Some (T.Pointer ty2)) when is_int_type ty1 ->
 187                   Some (T.Pointer ty2)
 188
 189               | (t1,t2) ->
 190                   let ty = lub_type t1 t2 in
 191                     Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty in
 192               (match Ast0.unwrap_mcode op with
 193                    Ast.Arith(op) -> same_type (ty1, ty2)
 194                  | Ast.Logical(Ast.AndLog) | Ast.Logical(Ast.OrLog) ->
 195                      Some(bool_type)
 196                  | Ast.Logical(op) ->
 197                      let ty = lub_type ty1 ty2 in
 198                      Ast0.set_type exp1 ty; Ast0.set_type exp2 ty;
 199                      Some(bool_type))
 200         | Ast0.Paren(lp,exp,rp) -> Ast0.get_type exp
 201         | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
 202             (match strip_cv (Ast0.get_type exp2) with
 203                  None -> Ast0.set_type exp2 (Some(int_type))
 204                | Some(ty) when is_int_type ty -> ()
 205                | Some(Type_cocci.Unknown) ->
 206                    (* unknown comes from param types, not sure why this
 207                       is not just None... *)
 208                    Ast0.set_type exp2 (Some(int_type))
 209                | Some ty -> err exp2 ty "bad type for an array index");
 210             (match strip_cv (Ast0.get_type exp1) with
 211                  None -> None
 212                | Some (T.Array(ty)) -> Some ty
 213                | Some (T.Pointer(ty)) -> Some ty
 214                | Some (T.MetaType(_,_,_)) -> None
 215                | Some x -> err exp1 x "ill-typed array reference")
 216               (* pad: should handle structure one day and look 'field' in environment *)
 217         | Ast0.RecordAccess(exp,pt,field) ->
 218             (match strip_cv (Ast0.get_type exp) with
 219                  None -> None
 220                | Some (T.StructUnionName(_,_)) -> None
 221                | Some (T.TypeName(_)) -> None
 222                | Some (T.MetaType(_,_,_)) -> None
 223                | Some x -> err exp x "non-structure type in field ref")
 224         | Ast0.RecordPtAccess(exp,ar,field) ->
 225             (match strip_cv (Ast0.get_type exp) with
 226                  None -> None
 227                | Some (T.Pointer(t)) ->
 228                    (match strip_cv (Some t) with
 229                       | Some (T.Unknown) -> None
 230                       | Some (T.MetaType(_,_,_)) -> None
 231                       | Some (T.TypeName(_)) -> None
 232                       | Some (T.StructUnionName(_,_)) -> None
 233                       | Some x ->
 234                           err exp (T.Pointer(t))
 235                             "non-structure pointer type in field ref"
 236                       | _ -> failwith "not possible")
 237                | Some (T.MetaType(_,_,_)) -> None
 238                | Some (T.TypeName(_)) -> None
 239                | Some x -> err exp x "non-structure pointer type in field ref")
 240         | Ast0.Cast(lp,ty,rp,exp) -> Some(Ast0.ast0_type_to_type ty)
 241         | Ast0.SizeOfExpr(szf,exp) -> Some(int_type)
 242         | Ast0.SizeOfType(szf,lp,ty,rp) -> Some(int_type)
 243         | Ast0.TypeExp(ty) -> None
 244         | Ast0.MetaErr(name,_,_) -> None
 245         | Ast0.MetaExpr(name,_,Some [ty],_,_) -> Some ty
 246         | Ast0.MetaExpr(name,_,ty,_,_) -> None
 247         | Ast0.MetaExprList(name,_,_) -> None
 248         | Ast0.EComma(cm) -> None
 249         | Ast0.DisjExpr(_,exp_list,_,_) ->
 250             let types = List.map Ast0.get_type exp_list in
 251             let combined = List.fold_left lub_type None types in
 252               (match combined with
 253                    None -> None
 254                  | Some t ->
 255                      List.iter (function e -> Ast0.set_type e (Some t)) exp_list;
 256                      Some t)
 257         | Ast0.NestExpr(starter,expr_dots,ender,None,multi) ->
 258             let _ = r.VT0.combiner_rec_expression_dots expr_dots in None
 259         | Ast0.NestExpr(starter,expr_dots,ender,Some e,multi) ->
 260             let _ = r.VT0.combiner_rec_expression_dots expr_dots in
 261             let _ = r.VT0.combiner_rec_expression e in None
 262         | Ast0.Edots(_,None) | Ast0.Ecircles(_,None) | Ast0.Estars(_,None) ->
 263             None
 264         | Ast0.Edots(_,Some e) | Ast0.Ecircles(_,Some e)
 265         | Ast0.Estars(_,Some e) ->
 266             let _ = r.VT0.combiner_rec_expression e in None
 267         | Ast0.OptExp(exp) -> Ast0.get_type exp
 268         | Ast0.UniqueExp(exp) -> Ast0.get_type exp in
 269       Ast0.set_type e ty;
 270       ty in
 271
 272   let rec strip id =
 273     match Ast0.unwrap id with
 274       Ast0.Id(name)                -> Id(Ast0.unwrap_mcode name)
 275     | Ast0.MetaId(name,_,_)        -> Meta(Ast0.unwrap_mcode name)
 276     | Ast0.MetaFunc(name,_,_)      -> Meta(Ast0.unwrap_mcode name)
 277     | Ast0.MetaLocalFunc(name,_,_) -> Meta(Ast0.unwrap_mcode name)
 278     | Ast0.OptIdent(id)            -> strip id
 279     | Ast0.UniqueIdent(id)         -> strip id in
 280
 281   let process_whencode notfn allfn exp = function
 282       Ast0.WhenNot(x) -> let _ = notfn x in ()
 283     | Ast0.WhenAlways(x) -> let _ = allfn x in ()
 284     | Ast0.WhenModifier(_) -> ()
 285     | Ast0.WhenNotTrue(x) -> let _ = exp x in ()
 286     | Ast0.WhenNotFalse(x) -> let _ = exp x in () in
 287
 288   (* assume that all of the declarations are at the beginning of a statement
 289      list, which is required by C, but not actually required by the cocci
 290      parser *)
 291   let rec process_statement_list r acc = function
 292       [] -> acc
 293     | (s::ss) ->
 294         (match Ast0.unwrap s with
 295           Ast0.Decl(_,decl) ->
 296             let new_acc = (process_decl acc decl)@acc in
 297             process_statement_list r new_acc ss
 298         | Ast0.Dots(_,wc) ->
 299             (* why is this case here?  why is there none for nests? *)
 300             List.iter
 301               (process_whencode r.VT0.combiner_rec_statement_dots
 302                  r.VT0.combiner_rec_statement r.VT0.combiner_rec_expression)
 303               wc;
 304             process_statement_list r acc ss
 305         | Ast0.Disj(_,statement_dots_list,_,_) ->
 306             let new_acc =
 307               lub_envs
 308                 (List.map
 309                    (function x -> process_statement_list r acc (Ast0.undots x))
 310                    statement_dots_list) in
 311             process_statement_list r new_acc ss
 312         | _ ->
 313             let _ = (propagate_types acc).VT0.combiner_rec_statement s in
 314             process_statement_list r acc ss)
 315
 316   and process_decl env decl =
 317     match Ast0.unwrap decl with
 318       Ast0.MetaDecl(_,_) | Ast0.MetaField(_,_) -> []
 319     | Ast0.Init(_,ty,id,_,exp,_) ->
 320         let _ =
 321           (propagate_types env).VT0.combiner_rec_initialiser exp in
 322         [(strip id,Ast0.ast0_type_to_type ty)]
 323     | Ast0.UnInit(_,ty,id,_) ->
 324         [(strip id,Ast0.ast0_type_to_type ty)]
 325     | Ast0.MacroDecl(_,_,_,_,_) -> []
 326     | Ast0.TyDecl(ty,_) -> []
 327               (* pad: should handle typedef one day and add a binding *)
 328     | Ast0.Typedef(_,_,_,_) -> []
 329     | Ast0.DisjDecl(_,disjs,_,_) ->
 330         List.concat(List.map (process_decl env) disjs)
 331     | Ast0.Ddots(_,_) -> [] (* not in a statement list anyway *)
 332     | Ast0.OptDecl(decl) -> process_decl env decl
 333     | Ast0.UniqueDecl(decl) -> process_decl env decl in
 334
 335   let statement_dots r k d =
 336     match Ast0.unwrap d with
 337       Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
 338         let _ = process_statement_list r env l in option_default in
 339
 340   let post_bool exp =
 341     let rec process_test exp =
 342       match (Ast0.unwrap exp,Ast0.get_type exp) with
 343         (Ast0.Edots(_,_),_) -> None
 344       | (Ast0.NestExpr(_,_,_,_,_),_) -> None
 345       | (Ast0.MetaExpr(_,_,_,_,_),_) ->
 346       (* if a type is known, it is specified in the decl *)
 347           None
 348       | (Ast0.Paren(lp,exp,rp),None) -> process_test exp
 349       (* the following doesn't seem like a good idea - triggers int isos
 350          on all test expressions *)
 351       (*| (_,None) -> Some (int_type) *)
 352       | _ -> None in
 353     let new_expty = process_test exp in
 354     (match new_expty with
 355       None -> () (* leave things as they are *)
 356     | Some ty -> Ast0.set_type exp new_expty) in
 357
 358   let statement r k s =
 359     match Ast0.unwrap s with
 360       Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
 361         let rec get_binding p =
 362           match Ast0.unwrap p with
 363             Ast0.Param(ty,Some id) ->
 364               [(strip id,Ast0.ast0_type_to_type ty)]
 365           | Ast0.OptParam(param) -> get_binding param
 366           | _ -> [] in
 367         let fenv = List.concat (List.map get_binding (Ast0.undots params)) in
 368         (propagate_types (fenv@env)).VT0.combiner_rec_statement_dots body
 369     | Ast0.IfThen(_,_,exp,_,_,_) | Ast0.IfThenElse(_,_,exp,_,_,_,_,_)
 370     | Ast0.While(_,_,exp,_,_,_) | Ast0.Do(_,_,_,_,exp,_,_)
 371     | Ast0.For(_,_,_,_,Some exp,_,_,_,_,_) ->
 372         let _ = k s in
 373         post_bool exp;
 374         None
 375     | Ast0.Switch(_,_,exp,_,_,decls,cases,_) ->
 376         let senv = process_statement_list r env (Ast0.undots decls) in
 377         let res =
 378           (propagate_types (senv@env)).VT0.combiner_rec_case_line_dots cases in
 379         post_bool exp;
 380         res
 381     |  _ -> k s
 382
 383   and case_line r k c =
 384     match Ast0.unwrap c with
 385       Ast0.Case(case,exp,colon,code) ->
 386         let _ = k c in
 387         (match Ast0.get_type exp with
 388           None -> Ast0.set_type exp (Some (int_type))
 389         | _ -> ());
 390         None
 391     | _ -> k c in
 392
 393   V0.combiner bind option_default
 394     {V0.combiner_functions with
 395       VT0.combiner_dotsstmtfn = statement_dots;
 396       VT0.combiner_identfn = ident;
 397       VT0.combiner_exprfn = expression;
 398       VT0.combiner_stmtfn = statement;
 399       VT0.combiner_casefn = case_line}
 400
 401 let type_infer code =
 402   let prop = propagate_types [(Id("NULL"),T.Pointer(T.Unknown))] in
 403   let fn = prop.VT0.combiner_rec_top_level in
 404   let _ = List.map fn code in
 405   ()