(* * * Copyright (c) 2001-2002, * George C. Necula * Scott McPeak * Wes Weimer * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (* mergecil.ml *) (* This module is responsible for merging multiple CIL source trees into * a single, coherent CIL tree which contains the union of all the * definitions in the source files. It effectively acts like a linker, * but at the source code level instead of the object code level. *) module P = Pretty open Cil module E = Errormsg module H = Hashtbl module A = Alpha open Trace let debugMerge = false let debugInlines = false let ignore_merge_conflicts = ref false (* Try to merge structure with the same name. However, do not complain if * they are not the same *) let mergeSynonyms = true (** Whether to use path compression *) let usePathCompression = false (* Try to merge definitions of inline functions. They can appear in multiple * files and we would like them all to be the same. This can slow down the * merger an order of magnitude !!! *) let mergeInlines = true let mergeInlinesRepeat = mergeInlines && true let mergeInlinesWithAlphaConvert = mergeInlines && true (* when true, merge duplicate definitions of externally-visible functions; * this uses a mechanism which is faster than the one for inline functions, * but only probabilistically accurate *) let mergeGlobals = true (* Return true if 's' starts with the prefix 'p' *) let prefix p s = let lp = String.length p in let ls = String.length s in lp <= ls && String.sub s 0 lp = p (* A name is identified by the index of the file in which it occurs (starting * at 0 with the first file) and by the actual name. We'll keep name spaces * separate *) (* We define a data structure for the equivalence classes *) type 'a node = { nname: string; (* The actual name *) nfidx: int; (* The file index *) ndata: 'a; (* Data associated with the node *) mutable nloc: (location * int) option; (* location where defined and index within the file of the definition. * If None then it means that this node actually DOES NOT appear in the * given file. In rare occasions we need to talk in a given file about * types that are not defined in that file. This happens with undefined * structures but also due to cross-contamination of types in a few of * the cases of combineType (see the definition of combineTypes). We * try never to choose as representatives nodes without a definition. * We also choose as representative the one that appears earliest *) mutable nrep: 'a node; (* A pointer to another node in its class (one * closer to the representative). The nrep node * is always in an earlier file, except for the * case where a name is undefined in one file * and defined in a later file. If this pointer * points to the node itself then this is the * representative. *) mutable nmergedSyns: bool (* Whether we have merged the synonyms for * the node of this name *) } let d_nloc () (lo: (location * int) option) : P.doc = match lo with None -> P.text "None" | Some (l, idx) -> P.dprintf "Some(%d at %a)" idx d_loc l (* Make a node with a self loop. This is quite tricky. *) let mkSelfNode (eq: (int * string, 'a node) H.t) (* The equivalence table *) (syn: (string, 'a node) H.t) (* The synonyms table *) (fidx: int) (name: string) (data: 'a) (l: (location * int) option) = let res = { nname = name; nfidx = fidx; ndata = data; nloc = l; nrep = Obj.magic 1; nmergedSyns = false; } in res.nrep <- res; (* Make the self cycle *) H.add eq (fidx, name) res; (* Add it to the proper table *) if mergeSynonyms && not (prefix "__anon" name) then H.add syn name res; res let debugFind = false (* Find the representative with or without path compression *) let rec find (pathcomp: bool) (nd: 'a node) = if debugFind then ignore (E.log " find %s(%d)\n" nd.nname nd.nfidx); if nd.nrep == nd then begin if debugFind then ignore (E.log " = %s(%d)\n" nd.nname nd.nfidx); nd end else begin let res = find pathcomp nd.nrep in if usePathCompression && pathcomp && nd.nrep != res then nd.nrep <- res; (* Compress the paths *) res end (* Union two nodes and return the new representative. We prefer as the * representative a node defined earlier. We try not to use as * representatives nodes that are not defined in their files. We return a * function for undoing the union. Make sure that between the union and the * undo you do not do path compression *) let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = (* Move to the representatives *) let nd1 = find true nd1 in let nd2 = find true nd2 in if nd1 == nd2 then begin (* It can happen that we are trying to union two nodes that are already * equivalent. This is because between the time we check that two nodes * are not already equivalent and the time we invoke the union operation * we check type isomorphism which might change the equivalence classes *) (* ignore (warn "unioning already equivalent nodes for %s(%d)" nd1.nname nd1.nfidx); *) nd1, fun x -> x end else begin let rep, norep = (* Choose the representative *) if (nd1.nloc != None) = (nd2.nloc != None) then (* They have the same defined status. Choose the earliest *) if nd1.nfidx < nd2.nfidx then nd1, nd2 else if nd1.nfidx > nd2.nfidx then nd2, nd1 else (* In the same file. Choose the one with the earliest index *) begin match nd1.nloc, nd2.nloc with Some (_, didx1), Some (_, didx2) -> if didx1 < didx2 then nd1, nd2 else if didx1 > didx2 then nd2, nd1 else begin ignore (warn "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file" nd1.nname nd2.nname nd1.nfidx didx1); nd1, nd2 end | _, _ -> (* both none. Does not matter which one we choose. Should * not happen though. *) (* sm: it does happen quite a bit when, e.g. merging STLport with * some client source; I'm disabling the warning since it supposedly * is harmless anyway, so is useless noise *) (* sm: re-enabling on claim it now will probably not happen *) ignore (warn "Merging two undefined elements in the same file: %s and %s\n" nd1.nname nd2.nname); nd1, nd2 end else (* One is defined, the other is not. Choose the defined one *) if nd1.nloc != None then nd1, nd2 else nd2, nd1 in let oldrep = norep.nrep in norep.nrep <- rep; rep, (fun () -> norep.nrep <- oldrep) end (* let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = if nd1 == nd2 && nd1.nname = "!!!intEnumInfo!!!" then begin ignore (warn "unioning two identical nodes for %s(%d)" nd1.nname nd1.nfidx); nd1, fun x -> x end else union nd1 nd2 *) (* Find the representative for a node and compress the paths in the process *) let findReplacement (pathcomp: bool) (eq: (int * string, 'a node) H.t) (fidx: int) (name: string) : ('a * int) option = if debugFind then ignore (E.log "findReplacement for %s(%d)\n" name fidx); try let nd = H.find eq (fidx, name) in if nd.nrep == nd then begin if debugFind then ignore (E.log " is a representative\n"); None (* No replacement if this is the representative of its class *) end else let rep = find pathcomp nd in if rep != rep.nrep then E.s (bug "find does not return the representative\n"); if debugFind then ignore (E.log " RES = %s(%d)\n" rep.nname rep.nfidx); Some (rep.ndata, rep.nfidx) with Not_found -> begin if debugFind then ignore (E.log " not found in the map\n"); None end (* Make a node if one does not already exist. Otherwise return the * representative *) let getNode (eq: (int * string, 'a node) H.t) (syn: (string, 'a node) H.t) (fidx: int) (name: string) (data: 'a) (l: (location * int) option) = let debugGetNode = false in if debugGetNode then ignore (E.log "getNode(%s(%d), %a)\n" name fidx d_nloc l); try let res = H.find eq (fidx, name) in (match res.nloc, l with (* Maybe we have a better location now *) None, Some _ -> res.nloc <- l | Some (old_l, old_idx), Some (l, idx) -> if old_idx != idx then ignore (warn "Duplicate definition of node %s(%d) at indices %d(%a) and %d(%a)" name fidx old_idx d_loc old_l idx d_loc l) else () | _, _ -> ()); if debugGetNode then ignore (E.log " node already found\n"); find false res (* No path compression *) with Not_found -> begin let res = mkSelfNode eq syn fidx name data l in if debugGetNode then ignore (E.log " made a new one\n"); res end (* Dump a graph *) let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit = ignore (E.log "Equivalence graph for %s is:\n" what); H.iter (fun (fidx, name) nd -> ignore (E.log " %s(%d) %s-> " name fidx (if nd.nloc = None then "(undef)" else "")); if nd.nrep == nd then ignore (E.log "*\n") else ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx )) eq (* For each name space we define a set of equivalence classes *) let vEq: (int * string, varinfo node) H.t = H.create 111 (* Vars *) let sEq: (int * string, compinfo node) H.t = H.create 111 (* Struct + union *) let eEq: (int * string, enuminfo node) H.t = H.create 111 (* Enums *) let tEq: (int * string, typeinfo node) H.t = H.create 111 (* Type names*) let iEq: (int * string, varinfo node) H.t = H.create 111 (* Inlines *) (* Sometimes we want to merge synonyms. We keep some tables indexed by names. * Each name is mapped to multiple exntries *) let vSyn: (string, varinfo node) H.t = H.create 111 (* Not actually used *) let iSyn: (string, varinfo node) H.t = H.create 111 (* Inlines *) let sSyn: (string, compinfo node) H.t = H.create 111 let eSyn: (string, enuminfo node) H.t = H.create 111 let tSyn: (string, typeinfo node) H.t = H.create 111 (** A global environment for variables. Put in here only the non-static * variables, indexed by their name. *) let vEnv : (string, varinfo node) H.t = H.create 111 (* A set of inline functions indexed by their printout ! *) let inlineBodies : (P.doc, varinfo node) H.t = H.create 111 (** A number of alpha conversion tables. We ought to keep one table for each * name space. Unfortunately, because of the way the C lexer works, type * names must be different from variable names!! We one alpha table both for * variables and types. *) let vtAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Variables and * types *) let sAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Structures and * unions have * the same name * space *) let eAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Enumerations *) (** Keep track, for all global function definitions, of the names of the formal * arguments. They might change during merging of function types if the * prototype occurs after the function definition and uses different names. * We'll restore the names at the end *) let formalNames: (int * string, string list) H.t = H.create 111 (* Accumulate here the globals in the merged file *) let theFileTypes = ref [] let theFile = ref [] (* add 'g' to the merged file *) let mergePushGlobal (g: global) : unit = pushGlobal g ~types:theFileTypes ~variables:theFile let mergePushGlobals gl = List.iter mergePushGlobal gl (* The index of the current file being scanned *) let currentFidx = ref 0 let currentDeclIdx = ref 0 (* The index of the definition in a file. This is * maintained both in pass 1 and in pass 2. Make * sure you count the same things in both passes. *) (* Keep here the file names *) let fileNames : (int, string) H.t = H.create 113 (* Remember the composite types that we have already declared *) let emittedCompDecls: (string, bool) H.t = H.create 113 (* Remember the variables also *) let emittedVarDecls: (string, bool) H.t = H.create 113 (* also keep track of externally-visible function definitions; * name maps to declaration, location, and semantic checksum *) let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113 (* and same for variable definitions; name maps to GVar fields *) let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113 (** A mapping from the new names to the original names. Used in PASS2 when we * rename variables. *) let originalVarNames: (string, string) H.t = H.create 113 (* Initialize the module *) let init () = H.clear sAlpha; H.clear eAlpha; H.clear vtAlpha; H.clear vEnv; H.clear vEq; H.clear sEq; H.clear eEq; H.clear tEq; H.clear iEq; H.clear vSyn; H.clear sSyn; H.clear eSyn; H.clear tSyn; H.clear iSyn; theFile := []; theFileTypes := []; H.clear formalNames; H.clear inlineBodies; currentFidx := 0; currentDeclIdx := 0; H.clear fileNames; H.clear emittedVarDecls; H.clear emittedCompDecls; H.clear emittedFunDefn; H.clear emittedVarDefn; H.clear originalVarNames (* Some enumerations have to be turned into an integer. We implement this by * introducing a special enumeration type which we'll recognize later to be * an integer *) let intEnumInfo = { ename = "!!!intEnumInfo!!!"; (* This is otherwise invalid *) eitems = []; eattr = []; ereferenced = false; } (* And add it to the equivalence graph *) let intEnumInfoNode = getNode eEq eSyn 0 intEnumInfo.ename intEnumInfo (Some (locUnknown, 0)) (* Combine the types. Raises the Failure exception with an error message. * isdef says whether the new type is for a definition *) type combineWhat = CombineFundef (* The new definition is for a function definition. The old * is for a prototype *) | CombineFunarg (* Comparing a function argument type with an old prototype * arg *) | CombineFunret (* Comparing the return of a function with that from an old * prototype *) | CombineOther let rec combineTypes (what: combineWhat) (oldfidx: int) (oldt: typ) (fidx: int) (t: typ) : typ = match oldt, t with | TVoid olda, TVoid a -> TVoid (addAttributes olda a) | TInt (oldik, olda), TInt (ik, a) -> let combineIK oldk k = if oldk == k then oldk else (* GCC allows a function definition to have a more precise integer * type than a prototype that says "int" *) if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 && (what = CombineFunarg || what = CombineFunret) then k else ( let msg = P.sprint ~width:80 (P.dprintf "(different integer types %a and %a)" d_type oldt d_type t) in raise (Failure msg) ) in TInt (combineIK oldik ik, addAttributes olda a) | TFloat (oldfk, olda), TFloat (fk, a) -> let combineFK oldk k = if oldk == k then oldk else (* GCC allows a function definition to have a more precise integer * type than a prototype that says "double" *) if not !msvcMode && oldk = FDouble && k = FFloat && (what = CombineFunarg || what = CombineFunret) then k else raise (Failure "(different floating point types)") in TFloat (combineFK oldfk fk, addAttributes olda a) | TEnum (oldei, olda), TEnum (ei, a) -> (* Matching enumerations always succeeds. But sometimes it maps both * enumerations to integers *) matchEnumInfo oldfidx oldei fidx ei; TEnum (oldei, addAttributes olda a) (* Strange one. But seems to be handled by GCC *) | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, addAttributes olda a) (* Strange one. But seems to be handled by GCC. Warning. Here we are * leaking types from new to old *) | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a) | TComp (oldci, olda) , TComp (ci, a) -> matchCompInfo oldfidx oldci fidx ci; (* If we get here we were successful *) TComp (oldci, addAttributes olda a) | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in let combinesz = match oldsz, sz with None, Some _ -> sz | Some _, None -> oldsz | None, None -> oldsz | Some oldsz', Some sz' -> let samesz = match constFold true oldsz', constFold true sz' with Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i | _, _ -> false in if samesz then oldsz else raise (Failure "(different array sizes)") in TArray (combbt, combinesz, addAttributes olda a) | TPtr (oldbt, olda), TPtr (bt, a) -> TPtr (combineTypes CombineOther oldfidx oldbt fidx bt, addAttributes olda a) (* WARNING: In this case we are leaking types from new to old !! *) | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t | TFun _, TFun (_, _, _, [Attr("missingproto",_)]) -> oldt | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> let newrt = combineTypes (if what = CombineFundef then CombineFunret else CombineOther) oldfidx oldrt fidx rt in if oldva != va then raise (Failure "(diferent vararg specifiers)"); (* If one does not have arguments, believe the one with the * arguments *) let newargs = if oldargs = None then args else if args = None then oldargs else let oldargslist = argsToList oldargs in let argslist = argsToList args in if List.length oldargslist <> List.length argslist then raise (Failure "(different number of arguments)") else begin (* Go over the arguments and update the old ones with the * adjusted types *) Some (List.map2 (fun (on, ot, oa) (an, at, aa) -> let n = if an <> "" then an else on in let t = combineTypes (if what = CombineFundef then CombineFunarg else CombineOther) oldfidx ot fidx at in let a = addAttributes oa aa in (n, t, a)) oldargslist argslist) end in TFun (newrt, newargs, oldva, addAttributes olda a) | TBuiltin_va_list olda, TBuiltin_va_list a -> TBuiltin_va_list (addAttributes olda a) | TNamed (oldt, olda), TNamed (t, a) -> matchTypeInfo oldfidx oldt fidx t; (* If we get here we were able to match *) TNamed(oldt, addAttributes olda a) (* Unroll first the new type *) | _, TNamed (t, a) -> let res = combineTypes what oldfidx oldt fidx t.ttype in typeAddAttributes a res (* And unroll the old type as well if necessary *) | TNamed (oldt, a), _ -> let res = combineTypes what oldfidx oldt.ttype fidx t in typeAddAttributes a res | _ -> ( (* raise (Failure "(different type constructors)") *) let msg:string = (P.sprint 1000 (P.dprintf "(different type constructors: %a vs. %a)" d_type oldt d_type t)) in raise (Failure msg) ) (* Match two compinfos and throw a Failure if they do not match *) and matchCompInfo (oldfidx: int) (oldci: compinfo) (fidx: int) (ci: compinfo) : unit = if oldci.cstruct <> ci.cstruct then raise (Failure "(different struct/union types)"); (* See if we have a mapping already *) (* Make the nodes if not already made. Actually return the * representatives *) let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci None in let cinode = getNode sEq sSyn fidx ci.cname ci None in if oldcinode == cinode then (* We already know they are the same *) () else begin (* Replace with the representative data *) let oldci = oldcinode.ndata in let oldfidx = oldcinode.nfidx in let ci = cinode.ndata in let fidx = cinode.nfidx in let old_len = List.length oldci.cfields in let len = List.length ci.cfields in (* It is easy to catch here the case when the new structure is undefined * and the old one was defined. We just reuse the old *) (* More complicated is the case when the old one is not defined but the * new one is. We still reuse the old one and we'll take care of defining * it later with the new fields. * GN: 7/10/04, I could not find when is "later", so I added it below *) if len <> 0 && old_len <> 0 && old_len <> len then ( let curLoc = !currentLoc in (* d_global blows this away.. *) (trace "merge" (P.dprintf "different # of fields\n%d: %a\n%d: %a\n" old_len d_global (GCompTag(oldci,locUnknown)) len d_global (GCompTag(ci,locUnknown)) )); currentLoc := curLoc; let msg = Printf.sprintf "(different number of fields in %s and %s: %d != %d.)" oldci.cname ci.cname old_len len in raise (Failure msg) ); (* We check that they are defined in the same way. While doing this there * might be recursion and we have to watch for going into an infinite * loop. So we add the assumption that they are equal *) let newrep, undo = union oldcinode cinode in (* We check the fields but watch for Failure. We only do the check when * the lengths are the same. Due to the code above this the other * possibility is that one of the length is 0, in which case we reuse the * old compinfo. *) (* But what if the old one is the empty one ? *) if old_len = len then begin (try List.iter2 (fun oldf f -> if oldf.fbitfield <> f.fbitfield then raise (Failure "(different bitfield info)"); if oldf.fattr <> f.fattr then raise (Failure "(different field attributes)"); (* Make sure the types are compatible *) let newtype = combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype in (* Change the type in the representative *) oldf.ftype <- newtype; ) oldci.cfields ci.cfields with Failure reason -> begin (* Our assumption was wrong. Forget the isomorphism *) undo (); let msg = P.sprint ~width:80 (P.dprintf "\n\tFailed assumption that %s and %s are isomorphic %s@!%a@!%a" (compFullName oldci) (compFullName ci) reason dn_global (GCompTag(oldci,locUnknown)) dn_global (GCompTag(ci,locUnknown))) in raise (Failure msg) end) end else begin (* We will reuse the old one. One of them is empty. If the old one is * empty, copy over the fields from the new one. Won't this result in * all sorts of undefined types??? *) if old_len = 0 then oldci.cfields <- ci.cfields; end; (* We get here when we succeeded checking that they are equal, or one of * them was empty *) newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr; () end (* Match two enuminfos and throw a Failure if they do not match *) and matchEnumInfo (oldfidx: int) (oldei: enuminfo) (fidx: int) (ei: enuminfo) : unit = (* Find the node for this enum, no path compression. *) let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in let einode = getNode eEq eSyn fidx ei.ename ei None in if oldeinode == einode then (* We already know they are the same *) () else begin (* Replace with the representative data *) let oldei = oldeinode.ndata in let ei = einode.ndata in (* Try to match them. But if you cannot just make them both integers *) try (* We do not have a mapping. They better be defined in the same way *) if List.length oldei.eitems <> List.length ei.eitems then raise (Failure "(different number of enumeration elements)"); (* We check that they are defined in the same way. This is a fairly * conservative check. *) List.iter2 (fun (old_iname, old_iv, _) (iname, iv, _) -> if old_iname <> iname then raise (Failure "(different names for enumeration items)"); let samev = match constFold true old_iv, constFold true iv with Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i | _ -> false in if not samev then raise (Failure "(different values for enumeration items)")) oldei.eitems ei.eitems; (* Set the representative *) let newrep, _ = union oldeinode einode in (* We get here if the enumerations match *) newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr; () with Failure msg -> begin (* Get here if you cannot merge two enumeration nodes *) if oldeinode != intEnumInfoNode then begin let _ = union oldeinode intEnumInfoNode in () end; if einode != intEnumInfoNode then begin let _ = union einode intEnumInfoNode in () end; end end (* Match two typeinfos and throw a Failure if they do not match *) and matchTypeInfo (oldfidx: int) (oldti: typeinfo) (fidx: int) (ti: typeinfo) : unit = if oldti.tname = "" || ti.tname = "" then E.s (bug "matchTypeInfo for anonymous type\n"); (* Find the node for this enum, no path compression. *) let oldtnode = getNode tEq tSyn oldfidx oldti.tname oldti None in let tnode = getNode tEq tSyn fidx ti.tname ti None in if oldtnode == tnode then (* We already know they are the same *) () else begin (* Replace with the representative data *) let oldti = oldtnode.ndata in let oldfidx = oldtnode.nfidx in let ti = tnode.ndata in let fidx = tnode.nfidx in (* Check that they are the same *) (try ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype); with Failure reason -> begin let msg = P.sprint ~width:80 (P.dprintf "\n\tFailed assumption that %s and %s are isomorphic %s" oldti.tname ti.tname reason) in raise (Failure msg) end); let _ = union oldtnode tnode in () end (* Scan all files and do two things *) (* 1. Initialize the alpha renaming tables with the names of the globals so * that when we come in the second pass to generate new names, we do not run * into conflicts. *) (* 2. For all declarations of globals unify their types. In the process * construct a set of equivalence classes on type names, structure and * enumeration tags *) (* 3. We clean the referenced flags *) let rec oneFilePass1 (f:file) : unit = H.add fileNames !currentFidx f.fileName; if debugMerge || !E.verboseFlag then ignore (E.log "Pre-merging (%d) %s\n" !currentFidx f.fileName); currentDeclIdx := 0; if f.globinitcalled || f.globinit <> None then E.s (E.warn "Merging file %s has global initializer" f.fileName); (* We scan each file and we look at all global varinfo. We see if globals * with the same name have been encountered before and we merge those types * *) let matchVarinfo (vi: varinfo) (l: location * int) = ignore (Alpha.registerAlphaName vtAlpha None vi.vname !currentLoc); (* Make a node for it and put it in vEq *) let vinode = mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in try let oldvinode = find true (H.find vEnv vi.vname) in let oldloc, _ = match oldvinode.nloc with None -> E.s (bug "old variable is undefined") | Some l -> l in let oldvi = oldvinode.ndata in (* There is an old definition. We must combine the types. Do this first * because it might fail *) let newtype = try combineTypes CombineOther oldvinode.nfidx oldvi.vtype !currentFidx vi.vtype; with (Failure reason) -> begin (* Go ahead *) let f = if !ignore_merge_conflicts then warn else error in ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s " vi.vname (H.find fileNames !currentFidx) !currentFidx d_loc oldloc (H.find fileNames oldvinode.nfidx) oldvinode.nfidx reason); raise Not_found end in let newrep, _ = union oldvinode vinode in (* We do not want to turn non-"const" globals into "const" one. That * can happen if one file declares the variable a non-const while * others declare it as "const". *) if hasAttribute "const" (typeAttrs vi.vtype) != hasAttribute "const" (typeAttrs oldvi.vtype) then begin newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype; end else begin newrep.ndata.vtype <- newtype; end; (* clean up the storage. *) let newstorage = if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then oldvi.vstorage else if oldvi.vstorage = Extern then vi.vstorage (* Sometimes we turn the NoStorage specifier into Static for inline * functions *) else if oldvi.vstorage = Static && vi.vstorage = NoStorage then Static else begin ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a" vi.vname d_storage vi.vstorage d_storage oldvi.vstorage d_loc oldloc); vi.vstorage end in newrep.ndata.vstorage <- newstorage; newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr; () with Not_found -> (* Not present in the previous files. Remember it for * later *) H.add vEnv vi.vname vinode in List.iter (function | GVarDecl (vi, l) | GVar (vi, _, l) -> currentLoc := l; incr currentDeclIdx; vi.vreferenced <- false; if vi.vstorage <> Static then begin matchVarinfo vi (l, !currentDeclIdx); end | GFun (fdec, l) -> currentLoc := l; incr currentDeclIdx; (* Save the names of the formal arguments *) let _, args, _, _ = splitFunctionTypeVI fdec.svar in H.add formalNames (!currentFidx, fdec.svar.vname) (List.map (fun (fn, _, _) -> fn) (argsToList args)); fdec.svar.vreferenced <- false; (* Force inline functions to be static. *) (* GN: This turns out to be wrong. inline functions are external, * unless specified to be static. *) (* if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then fdec.svar.vstorage <- Static; *) if fdec.svar.vstorage <> Static then begin matchVarinfo fdec.svar (l, !currentDeclIdx) end else begin if fdec.svar.vinline && mergeInlines then (* Just create the nodes for inline functions *) ignore (getNode iEq iSyn !currentFidx fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx))) end (* Make nodes for the defined type and structure tags *) | GType (t, l) -> incr currentDeclIdx; t.treferenced <- false; if t.tname <> "" then (* The empty names are just for introducing * undefined comp tags *) ignore (getNode tEq tSyn !currentFidx t.tname t (Some (l, !currentDeclIdx))) else begin (* Go inside and clean the referenced flag for the * declared tags *) match t.ttype with TComp (ci, _) -> ci.creferenced <- false; (* Create a node for it *) ignore (getNode sEq sSyn !currentFidx ci.cname ci None) | TEnum (ei, _) -> ei.ereferenced <- false; ignore (getNode eEq eSyn !currentFidx ei.ename ei None); | _ -> E.s (bug "Anonymous Gtype is not TComp") end | GCompTag (ci, l) -> incr currentDeclIdx; ci.creferenced <- false; ignore (getNode sEq sSyn !currentFidx ci.cname ci (Some (l, !currentDeclIdx))) | GEnumTag (ei, l) -> incr currentDeclIdx; ei.ereferenced <- false; ignore (getNode eEq eSyn !currentFidx ei.ename ei (Some (l, !currentDeclIdx))) | _ -> ()) f.globals (* Try to merge synonyms. Do not give an error if they fail to merge *) let doMergeSynonyms (syn : (string, 'a node) H.t) (eq : (int * string, 'a node) H.t) (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that * throws Failure if no match *) : unit = H.iter (fun n node -> if not node.nmergedSyns then begin (* find all the nodes for the same name *) let all = H.find_all syn n in let rec tryone (classes: 'a node list) (* A number of representatives * for this name *) (nd: 'a node) : 'a node list (* Returns an expanded set * of classes *) = nd.nmergedSyns <- true; (* Compare in turn with all the classes we have so far *) let rec compareWithClasses = function [] -> [nd](* No more classes. Add this as a new class *) | c :: restc -> try compare c.nfidx c.ndata nd.nfidx nd.ndata; (* Success. Stop here the comparison *) c :: restc with Failure _ -> (* Failed. Try next class *) c :: (compareWithClasses restc) in compareWithClasses classes in (* Start with an empty set of classes for this name *) let _ = List.fold_left tryone [] all in () end) syn let matchInlines (oldfidx: int) (oldi: varinfo) (fidx: int) (i: varinfo) = let oldinode = getNode iEq iSyn oldfidx oldi.vname oldi None in let inode = getNode iEq iSyn fidx i.vname i None in if oldinode == inode then () else begin (* Replace with the representative data *) let oldi = oldinode.ndata in let oldfidx = oldinode.nfidx in let i = inode.ndata in let fidx = inode.nfidx in (* There is an old definition. We must combine the types. Do this first * because it might fail *) oldi.vtype <- combineTypes CombineOther oldfidx oldi.vtype fidx i.vtype; (* We get here if we have success *) (* Combine the attributes as well *) oldi.vattr <- addAttributes oldi.vattr i.vattr; (* Do not union them yet because we do not know that they are the same. * We have checked only the types so far *) () end (************************************************************ * * PASS 2 * * ************************************************************) (** Keep track of the functions we have used already in the file. We need * this to avoid removing an inline function that has been used already. * This can only occur if the inline function is defined after it is used * already; a bad style anyway *) let varUsedAlready: (string, unit) H.t = H.create 111 (** A visitor that renames uses of variables and types *) class renameVisitorClass = object (self) inherit nopCilVisitor (* This is either a global variable which we took care of, or a local * variable. Must do its type and attributes. *) method vvdec (vi: varinfo) = DoChildren (* This is a variable use. See if we must change it *) method vvrbl (vi: varinfo) : varinfo visitAction = if not vi.vglob then DoChildren else if vi.vreferenced then begin H.add varUsedAlready vi.vname (); DoChildren end else begin match findReplacement true vEq !currentFidx vi.vname with None -> DoChildren | Some (vi', oldfidx) -> if debugMerge then ignore (E.log "Renaming use of var %s(%d) to %s(%d)\n" vi.vname !currentFidx vi'.vname oldfidx); vi'.vreferenced <- true; H.add varUsedAlready vi'.vname (); ChangeTo vi' end (* The use of a type. Change only those types whose underlying info * is not a root. *) method vtype (t: typ) = match t with TComp (ci, a) when not ci.creferenced -> begin match findReplacement true sEq !currentFidx ci.cname with None -> DoChildren | Some (ci', oldfidx) -> if debugMerge then ignore (E.log "Renaming use of %s(%d) to %s(%d)\n" ci.cname !currentFidx ci'.cname oldfidx); ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a)) end | TEnum (ei, a) when not ei.ereferenced -> begin match findReplacement true eEq !currentFidx ei.ename with None -> DoChildren | Some (ei', _) -> if ei' == intEnumInfo then (* This is actually our friend intEnumInfo *) ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a)) else ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a)) end | TNamed (ti, a) when not ti.treferenced -> begin match findReplacement true tEq !currentFidx ti.tname with None -> DoChildren | Some (ti', _) -> ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a)) end | _ -> DoChildren (* The Field offset might need to be changed to use new compinfo *) method voffs = function Field (f, o) -> begin (* See if the compinfo was changed *) if f.fcomp.creferenced then DoChildren else begin match findReplacement true sEq !currentFidx f.fcomp.cname with None -> DoChildren (* We did not replace it *) | Some (ci', oldfidx) -> begin (* First, find out the index of the original field *) let rec indexOf (i: int) = function [] -> E.s (bug "Cannot find field %s in %s(%d)\n" f.fname (compFullName f.fcomp) !currentFidx) | f' :: rest when f' == f -> i | _ :: rest -> indexOf (i + 1) rest in let index = indexOf 0 f.fcomp.cfields in if List.length ci'.cfields <= index then E.s (bug "Too few fields in replacement %s(%d) for %s(%d)\n" (compFullName ci') oldfidx (compFullName f.fcomp) !currentFidx); let f' = List.nth ci'.cfields index in ChangeDoChildrenPost (Field (f', o), fun x -> x) end end end | _ -> DoChildren method vinitoffs o = (self#voffs o) (* treat initializer offsets same as lvalue offsets *) end let renameVisitor = new renameVisitorClass (** A visitor that renames uses of inline functions that were discovered in * pass 2 to be used before they are defined. This is like the renameVisitor * except it only looks at the variables (thus it is a bit more efficient) * and it also renames forward declarations of the inlines to be removed. *) class renameInlineVisitorClass = object (self) inherit nopCilVisitor (* This is a variable use. See if we must change it *) method vvrbl (vi: varinfo) : varinfo visitAction = if not vi.vglob then DoChildren else if vi.vreferenced then begin (* Already renamed *) DoChildren end else begin match findReplacement true vEq !currentFidx vi.vname with None -> DoChildren | Some (vi', oldfidx) -> if debugMerge then ignore (E.log "Renaming var %s(%d) to %s(%d)\n" vi.vname !currentFidx vi'.vname oldfidx); vi'.vreferenced <- true; ChangeTo vi' end (* And rename some declarations of inlines to remove. We cannot drop this * declaration (see small1/combineinline6) *) method vglob = function GVarDecl(vi, l) when vi.vinline -> begin (* Get the original name *) let origname = try H.find originalVarNames vi.vname with Not_found -> vi.vname in (* Now see if this must be replaced *) match findReplacement true vEq !currentFidx origname with None -> DoChildren | Some (vi', _) -> ChangeTo [GVarDecl (vi', l)] end | _ -> DoChildren end let renameInlinesVisitor = new renameInlineVisitorClass (* sm: First attempt at a semantic checksum for function bodies. * Ideally, two function's checksums would be equal only when their * bodies were provably equivalent; but I'm using a much simpler and * less accurate heuristic here. It should be good enough for the * purpose I have in mind, which is doing duplicate removal of * multiply-instantiated template functions. *) let functionChecksum (dec: fundec) : int = begin (* checksum the structure of the statements (only) *) let rec stmtListSum (lst : stmt list) : int = (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst) and stmtSum (s: stmt) : int = (* strategy is to just throw a lot of prime numbers into the * computation in hopes of avoiding accidental collision.. *) match s.skind with | Instr(l) -> 13 + 67*(List.length l) | Return(_) -> 17 | Goto(_) -> 19 | Break(_) -> 23 | Continue(_) -> 29 | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts) + 41*(stmtListSum b2.bstmts) | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts) (* don't look at stmt list b/c is not part of tree *) | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts) | Block(b) -> 59 + 61*(stmtListSum b.bstmts) | TryExcept (b, (il, e), h, _) -> 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts) | TryFinally (b, h, _) -> 103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts) in (* disabled 2nd and 3rd measure because they appear to get different * values, for the same code, depending on whether the code was just * parsed into CIL or had previously been parsed into CIL, printed * out, then re-parsed into CIL *) let a,b,c,d,e = (List.length dec.sformals), (* # formals *) 0 (*(List.length dec.slocals)*), (* # locals *) 0 (*dec.smaxid*), (* estimate of internal statement count *) (List.length dec.sbody.bstmts), (* number of statements at outer level *) (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *) (*(trace "sm" (P.dprintf "sum: %s is %d %d %d %d %d\n"*) (* dec.svar.vname a b c d e));*) 2*a + 3*b + 5*c + 7*d + 11*e end (* sm: equality for initializers, etc.; this is like '=', except * when we reach shared pieces (like references into the type * structure), we use '==', to prevent circularity *) (* update: that's no good; I'm using this to find things which * are equal but from different CIL trees, so nothing will ever * be '=='.. as a hack I'll just change those places to 'true', * so these functions are not now checking proper equality.. * places where equality is not complete are marked "INC" *) let rec equalInits (x: init) (y: init) : bool = begin match x,y with | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye) | CompoundInit(xt, xoil), CompoundInit(yt, yoil) -> (*(xt == yt) &&*) (* INC *) (* types need to be identically equal *) let rec equalLists xoil yoil : bool = match xoil,yoil with | ((xo,xi) :: xrest), ((yo,yi) :: yrest) -> (equalOffsets xo yo) && (equalInits xi yi) && (equalLists xrest yrest) | [], [] -> true | _, _ -> false in (equalLists xoil yoil) | _, _ -> false end and equalOffsets (x: offset) (y: offset) : bool = begin match x,y with | NoOffset, NoOffset -> true | Field(xfi,xo), Field(yfi,yo) -> (xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *) (equalOffsets xo yo) | Index(xe,xo), Index(ye,yo) -> (equalExps xe ye) && (equalOffsets xo yo) | _,_ -> false end and equalExps (x: exp) (y: exp) : bool = begin match x,y with | Const(xc), Const(yc) -> xc = yc || (* safe to use '=' on literals *) ( (* CIL changes (unsigned)0 into 0U during printing.. *) match xc,yc with | CInt64(0L,_,_),CInt64(0L,_,_) -> true (* ok if they're both 0 *) | _,_ -> false ) | Lval(xl), Lval(yl) -> (equalLvals xl yl) | SizeOf(xt), SizeOf(yt) -> true (*INC: xt == yt*) (* identical types *) | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye) | AlignOf(xt), AlignOf(yt) -> true (*INC: xt == yt*) | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye) | UnOp(xop,xe,xt), UnOp(yop,ye,yt) -> xop = yop && (equalExps xe ye) && true (*INC: xt == yt*) | BinOp(xop,xe1,xe2,xt), BinOp(yop,ye1,ye2,yt) -> xop = yop && (equalExps xe1 ye1) && (equalExps xe2 ye2) && true (*INC: xt == yt*) | CastE(xt,xe), CastE(yt,ye) -> (*INC: xt == yt &&*) (equalExps xe ye) | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl) | StartOf(xl), StartOf(yl) -> (equalLvals xl yl) (* initializers that go through CIL multiple times sometimes lose casts they * had the first time; so allow a different of a cast *) | CastE(xt,xe), ye -> (equalExps xe ye) | xe, CastE(yt,ye) -> (equalExps xe ye) | _,_ -> false end and equalLvals (x: lval) (y: lval) : bool = begin match x,y with | (Var(xv),xo), (Var(yv),yo) -> (* I tried, I really did.. the problem is I see these names * before merging collapses them, so __T123 != __T456, * so whatever *) (*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*) (equalOffsets xo yo) | (Mem(xe),xo), (Mem(ye),yo) -> (equalExps xe ye) && (equalOffsets xo yo) | _,_ -> false end let equalInitOpts (x: init option) (y: init option) : bool = begin match x,y with | None,None -> true | Some(xi), Some(yi) -> (equalInits xi yi) | _,_ -> false end (* Now we go once more through the file and we rename the globals that we * keep. We also scan the entire body and we replace references to the * representative types or variables. We set the referenced flags once we * have replaced the names. *) let oneFilePass2 (f: file) = if debugMerge || !E.verboseFlag then ignore (E.log "Final merging phase (%d): %s\n" !currentFidx f.fileName); currentDeclIdx := 0; (* Even though we don't need it anymore *) H.clear varUsedAlready; H.clear originalVarNames; (* If we find inline functions that are used before being defined, and thus * before knowing that we can throw them away, then we mark this flag so * that we can make another pass over the file *) let repeatPass2 = ref false in (* Keep a pointer to the contents of the file so far *) let savedTheFile = !theFile in let processOneGlobal (g: global) : unit = (* Process a varinfo. Reuse an old one, or rename it if necessary *) let processVarinfo (vi: varinfo) (vloc: location) : varinfo = if vi.vreferenced then vi (* Already done *) else begin (* Maybe it is static. Rename it then *) if vi.vstorage = Static then begin let newName, _ = A.newAlphaName vtAlpha None vi.vname !currentLoc in (* Remember the original name *) H.add originalVarNames newName vi.vname; if debugMerge then ignore (E.log "renaming %s at %a to %s\n" vi.vname d_loc vloc newName); vi.vname <- newName; vi.vid <- newVID (); vi.vreferenced <- true; vi end else begin (* Find the representative *) match findReplacement true vEq !currentFidx vi.vname with None -> vi (* This is the representative *) | Some (vi', _) -> (* Reuse some previous one *) vi'.vreferenced <- true; (* Mark it as done already *) vi'.vaddrof <- vi.vaddrof || vi'.vaddrof; vi' end end in try match g with | GVarDecl (vi, l) as g -> currentLoc := l; incr currentDeclIdx; let vi' = processVarinfo vi l in if vi != vi' then (* Drop this declaration *) () else if H.mem emittedVarDecls vi'.vname then (* No need to keep it *) () else begin H.add emittedVarDecls vi'.vname true; (* Remember that we emitted * it *) mergePushGlobals (visitCilGlobal renameVisitor g) end | GVar (vi, init, l) -> currentLoc := l; incr currentDeclIdx; let vi' = processVarinfo vi l in (* We must keep this definition even if we reuse this varinfo, * because maybe the previous one was a declaration *) H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*) let emitIt:bool = (not mergeGlobals) || try let prevVar, prevInitOpt, prevLoc = (H.find emittedVarDefn vi'.vname) in (* previously defined; same initializer? *) if (equalInitOpts prevInitOpt init.init) || (init.init = None) then ( (trace "mergeGlob" (P.dprintf "dropping global var %s at %a in favor of the one at %a\n" vi'.vname d_loc l d_loc prevLoc)); false (* do not emit *) ) else if prevInitOpt = None then ( (* We have an initializer, but the previous one didn't. We should really convert the previous global from GVar to GVarDecl, but that's not convenient to do here. *) true ) else ( (* Both GVars have initializers. *) (E.s (error "global var %s at %a has different initializer than %a\n" vi'.vname d_loc l d_loc prevLoc)); ) with Not_found -> ( (* no previous definition *) (H.add emittedVarDefn vi'.vname (vi', init.init, l)); true (* emit it *) ) in if emitIt then mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l))) | GFun (fdec, l) as g -> currentLoc := l; incr currentDeclIdx; (* We apply the renaming *) fdec.svar <- processVarinfo fdec.svar l; (* Get the original name. *) let origname = try H.find originalVarNames fdec.svar.vname with Not_found -> fdec.svar.vname in (* Go in there and rename everything as needed *) let fdec' = match visitCilGlobal renameVisitor g with [GFun(fdec', _)] -> fdec' | _ -> E.s (unimp "renameVisitor for GFun returned something else") in let g' = GFun(fdec', l) in (* Now restore the parameter names *) let _, args, _, _ = splitFunctionTypeVI fdec'.svar in let oldnames, foundthem = try H.find formalNames (!currentFidx, origname), true with Not_found -> begin ignore (warnOpt "Cannot find %s in formalNames" origname); [], false end in if foundthem then begin let argl = argsToList args in if List.length oldnames <> List.length argl then E.s (unimp "After merging the function has more arguments"); List.iter2 (fun oldn a -> if oldn <> "" then a.vname <- oldn) oldnames fdec.sformals; (* Reflect them in the type *) setFormals fdec fdec.sformals end; (** See if we can remove this inline function *) if fdec'.svar.vinline && mergeInlines then begin let printout = (* Temporarily turn of printing of lines *) let oldprintln = !lineDirectiveStyle in lineDirectiveStyle := None; (* Temporarily set the name to all functions in the same way *) let newname = fdec'.svar.vname in fdec'.svar.vname <- "@@alphaname@@"; (* If we must do alpha conversion then temporarily set the * names of the local variables and formals in a standard way *) let nameId = ref 0 in let oldNames : string list ref = ref [] in let renameOne (v: varinfo) = oldNames := v.vname :: !oldNames; incr nameId; v.vname <- "___alpha" ^ string_of_int !nameId in let undoRenameOne (v: varinfo) = match !oldNames with n :: rest -> oldNames := rest; v.vname <- n | _ -> E.s (bug "undoRenameOne") in (* Remember the original type *) let origType = fdec'.svar.vtype in if mergeInlinesWithAlphaConvert then begin (* Rename the formals *) List.iter renameOne fdec'.sformals; (* Reflect in the type *) setFormals fdec' fdec'.sformals; (* Now do the locals *) List.iter renameOne fdec'.slocals end; (* Now print it *) let res = d_global () g' in lineDirectiveStyle := oldprintln; fdec'.svar.vname <- newname; if mergeInlinesWithAlphaConvert then begin (* Do the locals in reverse order *) List.iter undoRenameOne (List.rev fdec'.slocals); (* Do the formals in reverse order *) List.iter undoRenameOne (List.rev fdec'.sformals); (* Restore the type *) fdec'.svar.vtype <- origType; end; res in (* Make a node for this inline function using the original name. *) let inode = getNode vEq vSyn !currentFidx origname fdec'.svar (Some (l, !currentDeclIdx)) in if debugInlines then begin ignore (E.log "getNode %s(%d) with loc=%a. declidx=%d\n" inode.nname inode.nfidx d_nloc inode.nloc !currentDeclIdx); ignore (E.log "Looking for previous definition of inline %s(%d)\n" origname !currentFidx); end; try let oldinode = H.find inlineBodies printout in if debugInlines then ignore (E.log " Matches %s(%d)\n" oldinode.nname oldinode.nfidx); (* There is some other inline function with the same printout. * We should reuse this, but watch for the case when the inline * was already used. *) if H.mem varUsedAlready fdec'.svar.vname then begin if mergeInlinesRepeat then begin repeatPass2 := true end else begin ignore (warn "Inline function %s because it is used before it is defined" fdec'.svar.vname); raise Not_found end end; let _ = union oldinode inode in (* Clean up the vreferenced bit in the new inline, so that we * can rename it. Reset the name to the original one so that * we can find the replacement name. *) fdec'.svar.vreferenced <- false; fdec'.svar.vname <- origname; () (* Drop this definition *) with Not_found -> begin if debugInlines then ignore (E.log " Not found\n"); H.add inlineBodies printout inode; mergePushGlobal g' end end else begin (* either the function is not inline, or we're not attempting to * merge inlines *) if (mergeGlobals && not fdec'.svar.vinline && fdec'.svar.vstorage <> Static) then begin (* sm: this is a non-inline, non-static function. I want to * consider dropping it if a same-named function has already * been put into the merged file *) let curSum = (functionChecksum fdec') in (*(trace "mergeGlob" (P.dprintf "I see extern function %s, sum is %d\n"*) (* fdec'.svar.vname curSum));*) try let prevFun, prevLoc, prevSum = (H.find emittedFunDefn fdec'.svar.vname) in (* previous was found *) if (curSum = prevSum) then (trace "mergeGlob" (P.dprintf "dropping duplicate def'n of func %s at %a in favor of that at %a\n" fdec'.svar.vname d_loc l d_loc prevLoc)) else begin (* the checksums differ, so print a warning but keep the * older one to avoid a link error later. I think this is * a reasonable approximation of what ld does. *) (ignore (warn "def'n of func %s at %a (sum %d) conflicts with the one at %a (sum %d); keeping the one at %a.\n" fdec'.svar.vname d_loc l curSum d_loc prevLoc prevSum d_loc prevLoc)) end with Not_found -> begin (* there was no previous definition *) (mergePushGlobal g'); (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum)) end end else begin (* not attempting to merge global functions, or it was static * or inline *) mergePushGlobal g' end end | GCompTag (ci, l) as g -> begin currentLoc := l; incr currentDeclIdx; if ci.creferenced then () else begin match findReplacement true sEq !currentFidx ci.cname with None -> (* A new one, we must rename it and keep the definition *) (* Make sure this is root *) (try let nd = H.find sEq (!currentFidx, ci.cname) in if nd.nrep != nd then E.s (bug "Setting creferenced for struct %s(%d) which is not root!\n" ci.cname !currentFidx); with Not_found -> begin E.s (bug "Setting creferenced for struct %s(%d) which is not in the sEq!\n" ci.cname !currentFidx); end); let newname, _ = A.newAlphaName sAlpha None ci.cname !currentLoc in ci.cname <- newname; ci.creferenced <- true; ci.ckey <- H.hash (compFullName ci); (* Now we should visit the fields as well *) H.add emittedCompDecls ci.cname true; (* Remember that we * emitted it *) mergePushGlobals (visitCilGlobal renameVisitor g) | Some (oldci, oldfidx) -> begin (* We are not the representative. Drop this declaration * because we'll not be using it. *) () end end end | GEnumTag (ei, l) as g -> begin currentLoc := l; incr currentDeclIdx; if ei.ereferenced then () else begin match findReplacement true eEq !currentFidx ei.ename with None -> (* We must rename it *) let newname, _ = A.newAlphaName eAlpha None ei.ename !currentLoc in ei.ename <- newname; ei.ereferenced <- true; (* And we must rename the items to using the same name space * as the variables *) ei.eitems <- List.map (fun (n, i, loc) -> let newname, _ = A.newAlphaName vtAlpha None n !currentLoc in newname, i, loc) ei.eitems; mergePushGlobals (visitCilGlobal renameVisitor g); | Some (ei', _) -> (* Drop this since we are reusing it from * before *) () end end | GCompTagDecl (ci, l) -> begin currentLoc := l; (* This is here just to introduce an undefined * structure. But maybe the structure was defined * already. *) (* Do not increment currentDeclIdx because it is not incremented in * pass 1*) if H.mem emittedCompDecls ci.cname then () (* It was already declared *) else begin H.add emittedCompDecls ci.cname true; (* Keep it as a declaration *) mergePushGlobal g; end end | GEnumTagDecl (ei, l) -> currentLoc := l; (* Do not increment currentDeclIdx because it is not incremented in * pass 1*) (* Keep it as a declaration *) mergePushGlobal g | GType (ti, l) as g -> begin currentLoc := l; incr currentDeclIdx; if ti.treferenced then () else begin match findReplacement true tEq !currentFidx ti.tname with None -> (* We must rename it and keep it *) let newname, _ = A.newAlphaName vtAlpha None ti.tname !currentLoc in ti.tname <- newname; ti.treferenced <- true; mergePushGlobals (visitCilGlobal renameVisitor g); | Some (ti', _) ->(* Drop this since we are reusing it from * before *) () end end | g -> mergePushGlobals (visitCilGlobal renameVisitor g) with e -> begin let globStr:string = (P.sprint 1000 (P.dprintf "error when merging global %a: %s" d_global g (Printexc.to_string e))) in ignore (E.log "%s\n" globStr); (*"error when merging global: %s\n" (Printexc.to_string e);*) mergePushGlobal (GText (P.sprint 80 (P.dprintf "/* error at %t:" d_thisloc))); mergePushGlobal g; mergePushGlobal (GText ("*************** end of error*/")); raise e end in (* Now do the real PASS 2 *) List.iter processOneGlobal f.globals; (* See if we must re-visit the globals in this file because an inline that * is being removed was used before we saw the definition and we decided to * remove it *) if mergeInlinesRepeat && !repeatPass2 then begin if debugMerge || !E.verboseFlag then ignore (E.log "Repeat final merging phase (%d): %s\n" !currentFidx f.fileName); (* We are going to rescan the globals we have added while processing this * file. *) let theseGlobals : global list ref = ref [] in (* Scan a list of globals until we hit a given tail *) let rec scanUntil (tail: 'a list) (l: 'a list) = if tail == l then () else match l with | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n") | g :: rest -> theseGlobals := g :: !theseGlobals; scanUntil tail rest in (* Collect in theseGlobals all the globals from this file *) theseGlobals := []; scanUntil savedTheFile !theFile; (* Now reprocess them *) theFile := savedTheFile; List.iter (fun g -> theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile) !theseGlobals; (* Now check if we have inlines that we could not remove H.iter (fun name _ -> if not (H.mem inlinesRemoved name) then ignore (warn "Could not remove inline %s. I have no idea why!\n" name)) inlinesToRemove *) end let merge (files: file list) (newname: string) : file = init (); (* Make the first pass over the files *) currentFidx := 0; List.iter (fun f -> oneFilePass1 f; incr currentFidx) files; (* Now maybe try to force synonyms to be equal *) if mergeSynonyms then begin doMergeSynonyms sSyn sEq matchCompInfo; doMergeSynonyms eSyn eEq matchEnumInfo; doMergeSynonyms tSyn tEq matchTypeInfo; if mergeInlines then begin (* Copy all the nodes from the iEq to vEq as well. This is needed * because vEq will be used for variable renaming *) H.iter (fun k n -> H.add vEq k n) iEq; doMergeSynonyms iSyn iEq matchInlines; end end; (* Now maybe dump the graph *) if debugMerge then begin dumpGraph "type" tEq; dumpGraph "struct and union" sEq; dumpGraph "enum" eEq; dumpGraph "variable" vEq; if mergeInlines then dumpGraph "inline" iEq; end; (* Make the second pass over the files. This is when we start rewriting the * file *) currentFidx := 0; List.iter (fun f -> oneFilePass2 f; incr currentFidx) files; (* Now reverse the result and return the resulting file *) let rec revonto acc = function [] -> acc | x :: t -> revonto (x :: acc) t in let res = { fileName = newname; globals = revonto (revonto [] !theFile) !theFileTypes; globinit = None; globinitcalled = false;} in init (); (* Make the GC happy *) (* We have made many renaming changes and sometimes we have just guessed a * name wrong. Make sure now that the local names are unique. *) uniqueVarNames res; res