From a5f03d96eee482cd84861fc8cefff9eb451c0cad Mon Sep 17 00:00:00 2001 From: xleroy Date: Sun, 29 Mar 2009 09:47:11 +0000 Subject: Cleaned up configure script. Distribution of CIL as an expanded source tree with changes applied (instead of original .tar.gz + patches to be applied at config time). git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1020 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cil/src/rmtmps.ml | 778 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 778 insertions(+) create mode 100644 cil/src/rmtmps.ml (limited to 'cil/src/rmtmps.ml') diff --git a/cil/src/rmtmps.ml b/cil/src/rmtmps.ml new file mode 100644 index 00000000..b7dea931 --- /dev/null +++ b/cil/src/rmtmps.ml @@ -0,0 +1,778 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * 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. + * + *) + +(* rmtmps.ml *) +(* implementation for rmtmps.mli *) + +open Pretty +open Cil +module H = Hashtbl +module E = Errormsg +module U = Util + +(* Set on the command-line: *) +let keepUnused = ref false +let rmUnusedInlines = ref false + + +let trace = Trace.trace "rmtmps" + + + +(*********************************************************************** + * + * Clearing of "referenced" bits + * + *) + + +let clearReferencedBits file = + let considerGlobal global = + match global with + | GType (info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.treferenced <- false + + | GEnumTag (info, _) + | GEnumTagDecl (info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.ereferenced <- false + + | GCompTag (info, _) + | GCompTagDecl (info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.creferenced <- false + + | GVar ({vname = name} as info, _, _) + | GVarDecl ({vname = name} as info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.vreferenced <- false + + | GFun ({svar = info} as func, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.vreferenced <- false; + let clearMark local = + trace (dprintf "clearing mark: local %s\n" local.vname); + local.vreferenced <- false + in + List.iter clearMark func.slocals + + | _ -> + () + in + iterGlobals file considerGlobal + + +(*********************************************************************** + * + * Scanning and categorization of pragmas + * + *) + + +(* collections of names of things to keep *) +type collection = (string, unit) H.t +type keepers = { + typedefs : collection; + enums : collection; + structs : collection; + unions : collection; + defines : collection; + } + + +(* rapid transfer of control when we find a malformed pragma *) +exception Bad_pragma + +let ccureddeepcopystring = "ccureddeepcopy" +(* Save this length so we don't recompute it each time. *) +let ccureddeepcopystring_length = String.length ccureddeepcopystring + +(* CIL and CCured define several pragmas which prevent removal of + * various global symbols. Here we scan for those pragmas and build + * up collections of the corresponding symbols' names. + *) + +let categorizePragmas file = + + (* names of things which should be retained *) + let keepers = { + typedefs = H.create 0; + enums = H.create 0; + structs = H.create 0; + unions = H.create 0; + defines = H.create 1 + } in + + (* populate these name collections in light of each pragma *) + let considerPragma = + + let badPragma location pragma = + ignore (warnLoc location "Invalid argument to pragma %s" pragma) + in + + function + | GPragma (Attr ("cilnoremove" as directive, args), location) -> + (* a very flexible pragma: can retain typedefs, enums, + * structs, unions, or globals (functions or variables) *) + begin + let processArg arg = + try + match arg with + | AStr specifier -> + (* isolate and categorize one symbol name *) + let collection, name = + (* Two words denotes a typedef, enum, struct, or + * union, as in "type foo" or "enum bar". A + * single word denotes a global function or + * variable. *) + let whitespace = Str.regexp "[ \t]+" in + let words = Str.split whitespace specifier in + match words with + | ["type"; name] -> + keepers.typedefs, name + | ["enum"; name] -> + keepers.enums, name + | ["struct"; name] -> + keepers.structs, name + | ["union"; name] -> + keepers.unions, name + | [name] -> + keepers.defines, name + | _ -> + raise Bad_pragma + in + H.add collection name () + | _ -> + raise Bad_pragma + with Bad_pragma -> + badPragma location directive + in + List.iter processArg args + end + | GVarDecl (v, _) -> begin + (* Look for alias attributes, e.g. Linux modules *) + match filterAttributes "alias" v.vattr with + [] -> () (* ordinary prototype. *) + | [Attr("alias", [AStr othername])] -> + H.add keepers.defines othername () + | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc) + end + + (*** Begin CCured-specific checks: ***) + (* these pragmas indirectly require that we keep the function named in + -- the first arguments of boxmodelof and ccuredwrapperof, and + -- the third argument of ccureddeepcopy*. *) + | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), location) -> + begin + match attribute with + | AStr name -> + H.add keepers.defines name () + | _ -> + badPragma location directive + end + | GPragma (Attr("ccuredvararg", funcname :: (ASizeOf t) :: _), location) -> + begin + match t with + | TComp(c,_) when c.cstruct -> (* struct *) + H.add keepers.structs c.cname () + | TComp(c,_) -> (* union *) + H.add keepers.unions c.cname () + | TNamed(ti,_) -> + H.add keepers.typedefs ti.tname () + | TEnum(ei, _) -> + H.add keepers.enums ei.ename () + | _ -> + () + end + | GPragma (Attr(directive, _ :: _ :: attribute :: _), location) + when String.length directive > ccureddeepcopystring_length + && (Str.first_chars directive ccureddeepcopystring_length) + = ccureddeepcopystring -> + begin + match attribute with + | AStr name -> + H.add keepers.defines name () + | _ -> + badPragma location directive + end + (** end CCured-specific stuff **) + | _ -> + () + in + iterGlobals file considerPragma; + keepers + + + +(*********************************************************************** + * + * Function body elimination from pragmas + * + *) + + +(* When performing global slicing, any functions not explicitly marked + * as pragma roots are reduced to mere declarations. This leaves one + * with a reduced source file that still compiles to object code, but + * which contains the bodies of only explicitly retained functions. + *) + +let amputateFunctionBodies keptGlobals file = + let considerGlobal = function + | GFun ({svar = {vname = name} as info}, location) + when not (H.mem keptGlobals name) -> + trace (dprintf "slicing: reducing to prototype: function %s\n" name); + GVarDecl (info, location) + | other -> + other + in + mapGlobals file considerGlobal + + + +(*********************************************************************** + * + * Root collection from pragmas + * + *) + + +let isPragmaRoot keepers = function + | GType ({tname = name}, _) -> + H.mem keepers.typedefs name + | GEnumTag ({ename = name}, _) + | GEnumTagDecl ({ename = name}, _) -> + H.mem keepers.enums name + | GCompTag ({cname = name; cstruct = structure}, _) + | GCompTagDecl ({cname = name; cstruct = structure}, _) -> + let collection = if structure then keepers.structs else keepers.unions in + H.mem collection name + | GVar ({vname = name}, _, _) + | GVarDecl ({vname = name}, _) + | GFun ({svar = {vname = name}}, _) -> + H.mem keepers.defines name + | _ -> + false + + + +(*********************************************************************** + * + * Common root collecting utilities + * + *) + + +let traceRoot reason global = + trace (dprintf "root (%s): %a@!" reason d_shortglobal global); + true + + +let traceNonRoot reason global = + trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global); + false + + +let hasExportingAttribute funvar = + let rec isExportingAttribute = function + | Attr ("constructor", []) -> true + | Attr ("destructor", []) -> true + | _ -> false + in + List.exists isExportingAttribute funvar.vattr + + + +(*********************************************************************** + * + * Root collection from external linkage + * + *) + + +(* Exported roots are those global symbols which are visible to the + * linker and dynamic loader. For variables, this consists of + * anything that is not "static". For functions, this consists of: + * + * - functions bearing a "constructor" or "destructor" attribute + * - functions declared extern but not inline + * - functions declared neither inline nor static + * + * gcc incorrectly (according to C99) makes inline functions visible to + * the linker. So we can only remove inline functions on MSVC. + *) + +let isExportedRoot global = + let result, reason = match global with + | GVar ({vstorage = Static}, _, _) -> + false, "static variable" + | GVar _ -> + true, "non-static variable" + | GFun ({svar = v}, _) -> begin + if hasExportingAttribute v then + true, "constructor or destructor function" + else if v.vstorage = Static then + false, "static function" + else if v.vinline && v.vstorage != Extern + && (!msvcMode || !rmUnusedInlines) then + false, "inline function" + else + true, "other function" + end + | GVarDecl(v,_) when hasAttribute "alias" v.vattr -> + true, "has GCC alias attribute" + | _ -> + false, "neither function nor variable" + in + trace (dprintf "isExportedRoot %a -> %b, %s@!" + d_shortglobal global result reason); + result + + + +(*********************************************************************** + * + * Root collection for complete programs + * + *) + + +(* Exported roots are "main()" and functions bearing a "constructor" + * or "destructor" attribute. These are the only things which must be + * retained in a complete program. + *) + +let isCompleteProgramRoot global = + let result = match global with + | GFun ({svar = {vname = "main"; vstorage = vstorage}}, _) -> + vstorage <> Static + | GFun (fundec, _) + when hasExportingAttribute fundec.svar -> + true + | _ -> + false + in + trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global); + result + + +(*********************************************************************** + * + * Transitive reachability closure from roots + * + *) + + +(* This visitor recursively marks all reachable types and variables as used. *) +class markReachableVisitor + ((globalMap: (string, Cil.global) H.t), + (currentFunc: fundec option ref)) = object (self) + inherit nopCilVisitor + + method vglob = function + | GType (typeinfo, _) -> + typeinfo.treferenced <- true; + DoChildren + | GCompTag (compinfo, _) + | GCompTagDecl (compinfo, _) -> + compinfo.creferenced <- true; + DoChildren + | GEnumTag (enuminfo, _) + | GEnumTagDecl (enuminfo, _) -> + enuminfo.ereferenced <- true; + DoChildren + | GVar (varinfo, _, _) + | GVarDecl (varinfo, _) + | GFun ({svar = varinfo}, _) -> + varinfo.vreferenced <- true; + DoChildren + | _ -> + SkipChildren + + method vinst = function + Asm (_, tmpls, _, _, _, _) when !msvcMode -> + (* If we have inline assembly on MSVC, we cannot tell which locals + * are referenced. Keep thsem all *) + (match !currentFunc with + Some fd -> + List.iter (fun v -> + let vre = Str.regexp_string (Str.quote v.vname) in + if List.exists (fun tmp -> + try ignore (Str.search_forward vre tmp 0); true + with Not_found -> false) + tmpls + then + v.vreferenced <- true) fd.slocals + | _ -> assert false); + DoChildren + | _ -> DoChildren + + method vvrbl v = + if not v.vreferenced then + begin + let name = v.vname in + if v.vglob then + trace (dprintf "marking transitive use: global %s\n" name) + else + trace (dprintf "marking transitive use: local %s\n" name); + + (* If this is a global, we need to keep everything used in its + * definition and declarations. *) + if v.vglob then + begin + trace (dprintf "descending: global %s\n" name); + let descend global = + ignore (visitCilGlobal (self :> cilVisitor) global) + in + let globals = Hashtbl.find_all globalMap name in + List.iter descend globals + end + else + v.vreferenced <- true; + end; + SkipChildren + + method vexpr (e: exp) = + match e with + Const (CEnum (_, _, ei)) -> ei.ereferenced <- true; + DoChildren + | _ -> DoChildren + + method vtype typ = + let old : bool = + let visitAttrs attrs = + ignore (visitCilAttributes (self :> cilVisitor) attrs) + in + let visitType typ = + ignore (visitCilType (self :> cilVisitor) typ) + in + match typ with + | TEnum(e, attrs) -> + let old = e.ereferenced in + if not old then + begin + trace (dprintf "marking transitive use: enum %s\n" e.ename); + e.ereferenced <- true; + visitAttrs attrs; + visitAttrs e.eattr + end; + old + + | TComp(c, attrs) -> + let old = c.creferenced in + if not old then + begin + trace (dprintf "marking transitive use: compound %s\n" c.cname); + c.creferenced <- true; + + (* to recurse, we must ask explicitly *) + let recurse f = visitType f.ftype in + List.iter recurse c.cfields; + visitAttrs attrs; + visitAttrs c.cattr + end; + old + + | TNamed(ti, attrs) -> + let old = ti.treferenced in + if not old then + begin + trace (dprintf "marking transitive use: typedef %s\n" ti.tname); + ti.treferenced <- true; + + (* recurse deeper into the type referred-to by the typedef *) + (* to recurse, we must ask explicitly *) + visitType ti.ttype; + visitAttrs attrs + end; + old + + | _ -> + (* for anything else, just look inside it *) + false + in + if old then + SkipChildren + else + DoChildren +end + + +let markReachable file isRoot = + (* build a mapping from global names back to their definitions & + * declarations *) + let globalMap = Hashtbl.create 137 in + let considerGlobal global = + match global with + | GFun ({svar = info}, _) + | GVar (info, _, _) + | GVarDecl (info, _) -> + Hashtbl.add globalMap info.vname global + | _ -> + () + in + iterGlobals file considerGlobal; + + let currentFunc = ref None in + + (* mark everything reachable from the global roots *) + let visitor = new markReachableVisitor (globalMap, currentFunc) in + let visitIfRoot global = + if isRoot global then + begin + trace (dprintf "traversing root global: %a\n" d_shortglobal global); + (match global with + GFun(fd, _) -> currentFunc := Some fd + | _ -> currentFunc := None); + ignore (visitCilGlobal visitor global) + end + else + trace (dprintf "skipping non-root global: %a\n" d_shortglobal global) + in + iterGlobals file visitIfRoot + + +(********************************************************************** + * + * Marking and removing of unused labels + * + **********************************************************************) + +(* We keep only one label, preferably one that was not introduced by CIL. + * Scan a list of labels and return the data for the label that should be + * kept, and the remaining filtered list of labels *) +let labelsToKeep (ll: label list) : (string * location * bool) * label list = + let rec loop (sofar: string * location * bool) = function + [] -> sofar, [] + | l :: rest -> + let newlabel, keepl = + match l with + | Case _ | Default _ -> sofar, true + | Label (ln, lloc, isorig) -> begin + match isorig, sofar with + | false, ("", _, _) -> + (* keep this one only if we have no label so far *) + (ln, lloc, isorig), false + | false, _ -> sofar, false + | true, (_, _, false) -> + (* this is an original label; prefer it to temporary or + * missing labels *) + (ln, lloc, isorig), false + | true, _ -> sofar, false + end + in + let newlabel', rest' = loop newlabel rest in + newlabel', (if keepl then l :: rest' else rest') + in + loop ("", locUnknown, false) ll + +class markUsedLabels (labelMap: (string, unit) H.t) = object + inherit nopCilVisitor + + method vstmt (s: stmt) = + match s.skind with + Goto (dest, _) -> + let (ln, _, _), _ = labelsToKeep !dest.labels in + if ln = "" then + E.s (E.bug "rmtmps: destination of statement does not have labels"); + (* Mark it as used *) + H.replace labelMap ln (); + DoChildren + + | _ -> DoChildren + + (* No need to go into expressions or instructions *) + method vexpr _ = SkipChildren + method vinst _ = SkipChildren + method vtype _ = SkipChildren +end + +class removeUnusedLabels (labelMap: (string, unit) H.t) = object + inherit nopCilVisitor + + method vstmt (s: stmt) = + let (ln, lloc, lorig), lrest = labelsToKeep s.labels in + s.labels <- + (if ln <> "" && H.mem labelMap ln then (* We had labels *) + (Label(ln, lloc, lorig) :: lrest) + else + lrest); + DoChildren + + (* No need to go into expressions or instructions *) + method vexpr _ = SkipChildren + method vinst _ = SkipChildren + method vtype _ = SkipChildren +end + +(*********************************************************************** + * + * Removal of unused symbols + * + *) + + +(* regular expression matching names of uninteresting locals *) +let uninteresting = + let names = [ + (* Cil.makeTempVar *) + "__cil_tmp"; + + (* sm: I don't know where it comes from but these show up all over. *) + (* this doesn't seem to do what I wanted.. *) + "iter"; + + (* various macros in glibc's *) + "__result"; + "__s"; "__s1"; "__s2"; + "__s1_len"; "__s2_len"; + "__retval"; "__len"; + + (* various macros in glibc's *) + "__c"; "__res"; + + (* We remove the __malloc variables *) + ] in + + (* optional alpha renaming *) + let alpha = "\\(___[0-9]+\\)?" in + + let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in + Str.regexp pattern + + +let removeUnmarked file = + let removedLocals = ref [] in + + let filterGlobal global = + match global with + (* unused global types, variables, and functions are simply removed *) + | GType ({treferenced = false}, _) + | GCompTag ({creferenced = false}, _) + | GCompTagDecl ({creferenced = false}, _) + | GEnumTag ({ereferenced = false}, _) + | GEnumTagDecl ({ereferenced = false}, _) + | GVar ({vreferenced = false}, _, _) + | GVarDecl ({vreferenced = false}, _) + | GFun ({svar = {vreferenced = false}}, _) -> + trace (dprintf "removing global: %a\n" d_shortglobal global); + false + + (* retained functions may wish to discard some unused locals *) + | GFun (func, _) -> + let rec filterLocal local = + if not local.vreferenced then + begin + (* along the way, record the interesting locals that were removed *) + let name = local.vname in + trace (dprintf "removing local: %s\n" name); + if not (Str.string_match uninteresting name 0) then + removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals; + end; + local.vreferenced + in + func.slocals <- List.filter filterLocal func.slocals; + (* We also want to remove unused labels. We do it all here, including + * marking the used labels *) + let usedLabels:(string, unit) H.t = H.create 13 in + ignore (visitCilBlock (new markUsedLabels usedLabels) func.sbody); + (* And now we scan again and we remove them *) + ignore (visitCilBlock (new removeUnusedLabels usedLabels) func.sbody); + true + + (* all other globals are retained *) + | _ -> + trace (dprintf "keeping global: %a\n" d_shortglobal global); + true + in + file.globals <- List.filter filterGlobal file.globals; + !removedLocals + + +(*********************************************************************** + * + * Exported interface + * + *) + + +type rootsFilter = global -> bool + +let isDefaultRoot = isExportedRoot + +let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = + if !keepUnused || Trace.traceActive "disableTmpRemoval" then + Trace.trace "disableTmpRemoval" (dprintf "temp removal disabled\n") + else + begin + if !E.verboseFlag then + ignore (E.log "Removing unused temporaries\n" ); + + if Trace.traceActive "printCilTree" then + dumpFile defaultCilPrinter stdout "stdout" file; + + (* digest any pragmas that would create additional roots *) + let keepers = categorizePragmas file in + + (* if slicing, remove the bodies of non-kept functions *) + if !Cilutil.sliceGlobal then + amputateFunctionBodies keepers.defines file; + + (* build up the root set *) + let isRoot global = + isPragmaRoot keepers global || + isRoot global + in + + (* mark everything reachable from the global roots *) + clearReferencedBits file; + markReachable file isRoot; + + (* take out the trash *) + let removedLocals = removeUnmarked file in + + (* print which original source variables were removed *) + if false && removedLocals != [] then + let count = List.length removedLocals in + if count > 2000 then + ignore (E.warn "%d unused local variables removed" count) + else + ignore (E.warn "%d unused local variables removed:@!%a" + count (docList ~sep:(chr ',' ++ break) text) removedLocals) + end -- cgit