parsing_cocci/get_constants2.ml

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