parsing_cocci/get_constants2.ml

   1 (*
   2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
   4 * This file is part of Coccinelle.
   5 *
   6 * Coccinelle is free software: you can redistribute it and/or modify
   7 * it under the terms of the GNU General Public License as published by
   8 * the Free Software Foundation, according to version 2 of the License.
   9 *
  10 * Coccinelle is distributed in the hope that it will be useful,
  11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 * GNU General Public License for more details.
  14 *
  15 * You should have received a copy of the GNU General Public License
  16 * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17 *
  18 * The authors reserve the right to distribute this or future versions of
  19 * Coccinelle under other licenses.
  20 *)
  21
  22
  23 module Ast = Ast_cocci
  24 module V = Visitor_ast
  25 module TC = Type_cocci
  26
  27 (* Issues:
  28
  29 1.  If a rule X depends on a rule Y (in a positive way), then we can ignore
  30     the constants in X.
  31
  32 2.  If a rule X contains a metavariable that is not under a disjunction and
  33     that is inherited from rule Y, then we can ignore the constants in X.
  34
  35 3.  If a rule contains a constant x in + code then subsequent rules that
  36     have it in - or context should not include it in their list of required
  37     constants.
  38 *)
  39
  40 (* ----------------------------------------------------------------------- *)
  41 (* This phase collects everything.  One can then filter out what it not
  42 wanted *)
  43
  44 (* True means nothing was found
  45    False should never drift to the top, it is the neutral element of or
  46    and an or is never empty *)
  47 type combine =
  48     And of combine list | Or of combine list | Elem of string | False | True
  49
  50 let interpret strict x =
  51   let rec loop = function
  52       Elem x -> x
  53     | And [x] -> loop x
  54     | Or [x] -> loop x
  55     | And l -> Printf.sprintf "{%s}" (String.concat ";" (List.map loop l))
  56     | Or l -> Printf.sprintf "{%s}" (String.concat "," (List.map loop l))
  57     | True -> "True"
  58     | False ->
  59         if strict
  60         then failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
  61         else "False" in
  62   match x with
  63     True -> None
  64   | False when strict ->
  65       failwith "False should not be in the final result.  Perhaps your rule doesn't contain any +/-/* code"
  66   | _ -> Some (loop x)
  67
  68 let combine2c x =
  69   match interpret false x with
  70     None -> "None"
  71   | Some x -> x
  72
  73 let norm = function
  74     And l -> And (List.sort compare l)
  75   | Or l  -> Or (List.sort compare l)
  76   | x -> x
  77
  78 let rec merge l1 l2 =
  79   match (l1,l2) with
  80     ([],l2) -> l2
  81   | (l1,[]) -> l1
  82   | (x::xs,y::ys) ->
  83       (match compare x y with
  84         -1 -> x::(merge xs l2)
  85       | 0  -> x::(merge xs ys)
  86       | 1  -> y::(merge l1 ys)
  87       | _ -> failwith "not possible")
  88
  89 let intersect l1 l2 = List.filter (function l1e -> List.mem l1e l2) l1
  90
  91 let minus_set l1 l2 = List.filter (function l1e -> not (List.mem l1e l2)) l1
  92
  93 let rec insert x l = merge [x] l
  94
  95 let rec build_and x y =
  96   if x = y
  97   then x
  98   else
  99     match (x,y) with
 100       (True,x) | (x,True) -> x
 101     | (False,x) | (x,False) -> False
 102     | (And l1,And l2) -> And (merge l1 l2)
 103     | (x,Or l) when List.mem x l -> x
 104     | (Or l,x) when List.mem x l -> x
 105     | (Or l1,Or l2) when not ((intersect l1 l2) = []) ->
 106         let inner =
 107           build_and
 108             (List.fold_left build_or False (minus_set l1 l2))
 109             (List.fold_left build_or False (minus_set l2 l1)) in
 110         List.fold_left build_or inner (intersect l1 l2)
 111     | (x,And l) | (And l,x) ->
 112         if List.mem x l
 113         then And l
 114         else
 115           let others =
 116             List.filter
 117               (function
 118                   Or l -> not(List.mem x l)
 119                 | _ -> true)
 120               l in
 121           And (insert x others)
 122     | (x,y) -> norm(And [x;y])
 123
 124 and build_or x y =
 125   if x = y
 126   then x
 127   else
 128     match (x,y) with
 129       (True,x) | (x,True) -> True
 130     | (False,x) | (x,False) -> x
 131     | (Or l1,Or l2) -> Or (merge l1 l2)
 132     | (x,And l) when List.mem x l -> x
 133     | (And l,x) when List.mem x l -> x
 134     | (And l1,And l2) when not ((intersect l1 l2) = []) ->
 135         let inner =
 136           build_or
 137             (List.fold_left build_and True (minus_set l1 l2))
 138             (List.fold_left build_and True (minus_set l2 l1)) in
 139         List.fold_left build_and inner (intersect l1 l2)
 140     | (x,Or l) | (Or l,x) ->
 141         if List.mem x l
 142         then Or l
 143         else
 144           let others =
 145             List.filter
 146               (function
 147                   And l -> not(List.mem x l)
 148                 | _ -> true)
 149               l in
 150           Or (insert x others)
 151     | (x,y) -> norm(Or [x;y])
 152
 153 let keep x = Elem x
 154 let drop x = True
 155
 156 let do_get_constants constants keywords env neg_pos =
 157   let donothing r k e = k e in
 158   let option_default = True in
 159   let bind = build_and in
 160   let inherited ((nm1,_) as x) =
 161     (* perhaps inherited, but value not required, so no constraints *)
 162     if List.mem x neg_pos then option_default
 163     else try List.assoc nm1 env with Not_found -> False in
 164   let minherited name = inherited (Ast.unwrap_mcode name) in
 165   let mcode _ x =
 166     match Ast.get_pos_var x with
 167       Ast.MetaPos(name,constraints,_,keep,inh) -> minherited name
 168     | _ -> option_default in
 169
 170   (* if one branch gives no information, then we have to take anything *)
 171   let disj_union_all = List.fold_left build_or False in
 172
 173   let ident r k i =
 174     match Ast.unwrap i with
 175       Ast.Id(name) ->
 176         bind (k i)
 177           (match Ast.unwrap_mcode name with
 178             "NULL" -> keywords "NULL"
 179           | nm -> constants nm)
 180     | Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
 181     | Ast.MetaLocalFunc(name,_,_,_) -> bind (k i) (minherited name)
 182     | _ -> k i in
 183
 184   let rec type_collect res = function
 185       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 186     | TC.Array(ty) -> type_collect res ty
 187     | TC.MetaType(tyname,_,_) -> inherited tyname
 188     | TC.TypeName(s) -> constants s
 189     | TC.EnumName(false,s) -> constants s
 190     | TC.StructUnionName(_,false,s) -> constants s
 191     | ty -> res in
 192
 193   (* no point to do anything special for records because glimpse is
 194      word-oriented *)
 195   let expression r k e =
 196     match Ast.unwrap e with
 197       Ast.Constant(const) ->
 198         bind (k e)
 199           (match Ast.unwrap_mcode const with
 200             Ast.String s -> constants s
 201           | Ast.Char "\\0" -> option_default (* glimpse doesn't like it *)
 202           | Ast.Char s -> constants s
 203           (* the following were eg keywords "1", but not good for glimpse *)
 204           | Ast.Int "0" -> option_default (* glimpse doesn't like it *)
 205           | Ast.Int "1" -> option_default (* glimpse doesn't like it *)
 206           | Ast.Int s -> constants s
 207           | Ast.Float s -> constants s)
 208     | Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 209         let types = List.fold_left type_collect option_default type_list in
 210         bind (k e) (bind (minherited name) types)
 211     | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) ->
 212         bind (k e) (minherited name)
 213     | Ast.MetaExprList(name,None,_,_) -> minherited name
 214     | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
 215         bind (k e) (bind (minherited name) (minherited lenname))
 216     | Ast.SizeOfExpr(sizeof,exp) -> bind (keywords "sizeof") (k e)
 217     | Ast.SizeOfType(sizeof,lp,ty,rp) -> bind (keywords "sizeof") (k e)
 218     | Ast.NestExpr(expr_dots,wc,false) -> option_default
 219     | Ast.NestExpr(expr_dots,wc,true) ->
 220         r.V.combiner_expression_dots expr_dots
 221     | Ast.DisjExpr(exps) ->
 222         disj_union_all (List.map r.V.combiner_expression exps)
 223     | Ast.OptExp(exp) -> option_default
 224     | Ast.Edots(_,_) | Ast.Ecircles(_,_) | Ast.Estars(_,_) -> option_default
 225     | _ -> k e in
 226
 227   let fullType r k ft =
 228     match Ast.unwrap ft with
 229       Ast.DisjType(decls) ->
 230         disj_union_all (List.map r.V.combiner_fullType decls)
 231     | Ast.OptType(ty) -> option_default
 232     | _ -> k ft in
 233
 234   let baseType = function
 235       Ast.VoidType -> keywords "void "
 236     | Ast.CharType -> keywords "char "
 237     | Ast.ShortType -> keywords "short "
 238     | Ast.IntType -> keywords "int "
 239     | Ast.DoubleType -> keywords "double "
 240     | Ast.FloatType -> keywords "float "
 241     | Ast.LongType | Ast.LongLongType -> keywords "long " in
 242
 243   let typeC r k ty =
 244     match Ast.unwrap ty with
 245       Ast.BaseType(ty1,strings) -> bind (k ty) (baseType ty1)
 246     | Ast.TypeName(name) -> bind (k ty) (constants (Ast.unwrap_mcode name))
 247     | Ast.MetaType(name,_,_) -> bind (minherited name) (k ty)
 248     | _ -> k ty in
 249
 250   let declaration r k d =
 251     match Ast.unwrap d with
 252       Ast.DisjDecl(decls) ->
 253         disj_union_all (List.map r.V.combiner_declaration decls)
 254     | Ast.OptDecl(decl) -> option_default
 255     | Ast.Ddots(dots,whencode) -> option_default
 256     | _ -> k d in
 257
 258   let initialiser r k i =
 259     match Ast.unwrap i with
 260       Ast.OptIni(ini) -> option_default
 261     | _ -> k i in
 262
 263   let parameter r k p =
 264     match Ast.unwrap p with
 265       Ast.OptParam(param) -> option_default
 266     | Ast.MetaParam(name,_,_) -> bind (k p) (minherited name)
 267     | Ast.MetaParamList(name,None,_,_) -> bind (k p) (minherited name)
 268     | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
 269         bind (minherited name) (bind (minherited lenname) (k p))
 270     | _ -> k p in
 271
 272   let rule_elem r k re =
 273     match Ast.unwrap re with
 274       Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 275     | Ast.MetaStmtList(name,_,_) -> bind (minherited name) (k re)
 276     | Ast.WhileHeader(whl,lp,exp,rp) ->
 277         bind (keywords "while") (k re)
 278     | Ast.WhileTail(whl,lp,exp,rp,sem) ->
 279         bind (keywords "do") (k re)
 280     | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
 281         bind (keywords "for") (k re)
 282     | Ast.SwitchHeader(switch,lp,exp,rp) ->
 283         bind (keywords "switch") (k re)
 284     | Ast.Break(br,sem) ->
 285         bind (keywords "break") (k re)
 286     | Ast.Continue(cont,sem) ->
 287         bind (keywords "continue") (k re)
 288     | Ast.Goto(_,i,_) ->
 289         bind (keywords "goto") (k re)
 290     | Ast.Default(def,colon) ->
 291         bind (keywords "default") (k re)
 292     | Ast.Include(inc,s) ->
 293         bind (k re)
 294           (match Ast.unwrap_mcode s with
 295             Ast.Local l | Ast.NonLocal l ->
 296               let strings =
 297                 List.fold_left
 298                   (function prev ->
 299                     function
 300                         (* just take the last thing, probably the most
 301                            specific.  everything is necessary anyway. *)
 302                         Ast.IncPath s -> [Elem s]
 303                       | Ast.IncDots -> prev)
 304                   [] l in
 305               (match strings with
 306                 [] -> True
 307               | x::xs -> List.fold_left bind x xs))
 308     | Ast.DisjRuleElem(res) ->
 309         disj_union_all (List.map r.V.combiner_rule_elem res)
 310     | _ -> k re in
 311
 312   let statement r k s =
 313     match Ast.unwrap s with
 314       Ast.Disj(stmt_dots) ->
 315         disj_union_all (List.map r.V.combiner_statement_dots stmt_dots)
 316     | Ast.Nest(stmt_dots,whn,false,_,_) -> option_default
 317     | Ast.Nest(stmt_dots,whn,true,_,_) ->
 318         r.V.combiner_statement_dots stmt_dots
 319     | Ast.OptStm(s) -> option_default
 320     | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
 321         option_default
 322     | _ -> k s in
 323
 324   V.combiner bind option_default
 325     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 326     donothing donothing donothing donothing
 327     ident expression fullType typeC initialiser parameter declaration
 328     rule_elem statement donothing donothing donothing
 329
 330 (* ------------------------------------------------------------------------ *)
 331
 332 let filter_combine combine to_drop =
 333   let rec and_loop = function
 334       Elem x when List.mem x to_drop -> True
 335     | Or l ->  List.fold_left build_or  False (List.map or_loop l)
 336     | x -> x
 337   and or_loop = function
 338       Elem x when List.mem x to_drop -> False
 339     | And l -> List.fold_left build_and True  (List.map and_loop l)
 340     | x -> x in
 341  or_loop combine
 342
 343 (* ------------------------------------------------------------------------ *)
 344
 345 let get_all_constants minus_only =
 346   let donothing r k e = k e in
 347   let bind = Common.union_set in
 348   let option_default = [] in
 349   let mcode r (x,_,mcodekind,_) =
 350     match mcodekind with
 351       Ast.MINUS(_,_) -> [x]
 352     | _ when minus_only -> []
 353     | _ -> [x] in
 354   let other r _ = [] in
 355
 356   V.combiner bind option_default
 357     other mcode other other other other other other other other other other
 358
 359     donothing donothing donothing donothing
 360     donothing donothing donothing donothing donothing donothing donothing
 361     donothing donothing donothing donothing donothing
 362
 363 (* ------------------------------------------------------------------------ *)
 364
 365 let get_plus_constants =
 366   let donothing r k e = k e in
 367   let bind = Common.union_set in
 368   let option_default = [] in
 369   let mcode r mc =
 370     let mcodekind = Ast.get_mcodekind mc in
 371     let recurse l =
 372       List.fold_left
 373         (List.fold_left
 374            (function prev ->
 375              function cur ->
 376                bind ((get_all_constants false).V.combiner_anything cur) prev))
 377         [] l in
 378     match mcodekind with
 379       Ast.MINUS(_,anythings) -> recurse anythings
 380     | Ast.CONTEXT(_,Ast.BEFORE(a)) -> recurse a
 381     | Ast.CONTEXT(_,Ast.AFTER(a)) -> recurse a
 382     | Ast.CONTEXT(_,Ast.BEFOREAFTER(a1,a2)) ->
 383         Common.union_set (recurse a1) (recurse a2)
 384     | _ -> [] in
 385
 386   V.combiner bind option_default
 387     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 388     donothing donothing donothing donothing
 389     donothing donothing donothing donothing donothing donothing donothing
 390     donothing donothing donothing donothing donothing
 391
 392 (* ------------------------------------------------------------------------ *)
 393
 394 (* true means the rule should be analyzed, false means it should be ignored *)
 395 let rec dependencies env = function
 396     Ast.Dep s -> (try List.assoc s env with Not_found -> False)
 397   | Ast.AntiDep s -> True
 398   | Ast.EverDep s -> (try List.assoc s env with Not_found -> False)
 399   | Ast.NeverDep s -> True
 400   | Ast.AndDep (d1,d2) -> build_and (dependencies env d1) (dependencies env d2)
 401   | Ast.OrDep (d1,d2) -> build_or (dependencies env d1) (dependencies env d2)
 402   | Ast.NoDep -> True
 403
 404 (* ------------------------------------------------------------------------ *)
 405
 406 let all_context =
 407   let bind x y = x && y in
 408   let option_default = true in
 409
 410   let donothing recursor k e = k e in
 411
 412   let mcode r e =
 413     match Ast.get_mcodekind e with
 414       Ast.CONTEXT(_,Ast.NOTHING) -> true
 415     | _ -> false in
 416
 417   V.combiner bind option_default
 418     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 419     donothing donothing donothing donothing
 420     donothing donothing donothing donothing donothing donothing
 421     donothing donothing donothing donothing donothing donothing
 422
 423 (* ------------------------------------------------------------------------ *)
 424
 425 let rule_fn tls in_plus env neg_pos =
 426   List.fold_left
 427     (function (rest_info,in_plus) ->
 428       function (cur,neg_pos) ->
 429         let minuses =
 430           (do_get_constants keep drop env neg_pos).V.combiner_top_level cur in
 431         let all_minuses =
 432           if !Flag.sgrep_mode2
 433           then [] (* nothing removed for sgrep *)
 434           else (get_all_constants true).V.combiner_top_level cur in
 435         let plusses = get_plus_constants.V.combiner_top_level cur in
 436         (* the following is for eg -foo(2) +foo(x) then in another rule
 437            -foo(10); don't want to consider that foo is guaranteed to be
 438            created by the rule.  not sure this works completely: what if foo is
 439            in both - and +, but in an or, so the cases aren't related?
 440            not sure this whole thing is a good idea.  how do we know that
 441            something that is only in plus is really freshly created? *)
 442         let plusses = Common.minus_set plusses all_minuses in
 443         let was_bot = minuses = True in
 444         let new_minuses = filter_combine minuses in_plus in
 445         let new_plusses = Common.union_set plusses in_plus in
 446         (* perhaps it should be build_and here?  we don't realy have multiple
 447            minirules anymore anyway. *)
 448         match new_minuses with
 449           True ->
 450             let retry =
 451               (do_get_constants drop keep env neg_pos).V.combiner_top_level
 452                 cur in
 453             (match retry with
 454               True when not was_bot -> (rest_info, new_plusses)
 455             | x -> (build_or x rest_info, new_plusses))
 456         | x -> (build_or x rest_info, new_plusses))
 457     (False,in_plus) (List.combine tls neg_pos)
 458
 459 let get_constants rules neg_pos_vars =
 460   if not !Flag.use_glimpse
 461   then None
 462   else
 463     let (info,_,_,_) =
 464       List.fold_left
 465         (function (rest_info,in_plus,env,locals(*dom of env*)) ->
 466           function
 467               (Ast.ScriptRule (_,deps,mv,_),_) ->
 468                 let extra_deps =
 469                   List.fold_left
 470                     (function prev ->
 471                       function (_,(rule,_)) -> Ast.AndDep (Ast.Dep rule,prev))
 472                     deps mv in
 473                 (match dependencies env extra_deps with
 474                   False -> (rest_info, in_plus, env, locals)
 475                 | dependencies ->
 476                     (build_or dependencies rest_info, in_plus, env, locals))
 477             | (Ast.InitialScriptRule (_,_),_)
 478             | (Ast.FinalScriptRule (_,_),_) -> (rest_info,in_plus,env,locals)
 479             | (Ast.CocciRule (nm,(dep,_,_),cur,_,_),neg_pos_vars) ->
 480                 let (cur_info,cur_plus) =
 481                   rule_fn cur in_plus ((nm,True)::env) neg_pos_vars in
 482                 if List.for_all all_context.V.combiner_top_level cur
 483                 then (rest_info,cur_plus,(nm,cur_info)::env,nm::locals)
 484                 else
 485                (* no constants if dependent on another rule; then we need to
 486                   find the constants of that rule *)
 487                   match dependencies env dep with
 488                     False -> (rest_info,cur_plus,env,locals)
 489                   | dependencies ->
 490                       (build_or (build_and dependencies cur_info) rest_info,
 491                        cur_plus,env,locals))
 492         (False,[],[],[]) (List.combine (rules : Ast.rule list) neg_pos_vars) in
 493     interpret true info