/src/cil.ml
OCaml | 7133 lines | 4914 code | 843 blank | 1376 comment | 749 complexity | 2516d5954db74d71c239e40812629e61 MD5 | raw file
Possible License(s): BSD-3-Clause
- (*
- *
- * Copyright (c) 2001-2003,
- * George C. Necula <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * Ben Liblit <liblit@cs.berkeley.edu>
- * 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.
- *
- *)
- open Escape
- open Pretty
- open Cilint
- (* open Trace (\* sm: 'trace' function *\) *)
- module E = Errormsg
- module H = Hashtbl
- module IH = Inthash
- (*
- * CIL: An intermediate language for analyzing C progams.
- *
- * Scott McPeak, George Necula, Wes Weimer
- *
- *)
- (* The module Cilversion is generated automatically by Makefile from
- * information in configure.in *)
- let cilVersion = Cilversion.cilVersion
- let cilVersionMajor = Cilversion.cilVersionMajor
- let cilVersionMinor = Cilversion.cilVersionMinor
- let cilVersionRevision = Cilversion.cilVersionRev
- (* A few globals that control the interpretation of C source *)
- let msvcMode = ref false (* Whether the pretty printer should
- * print output for the MS VC
- * compiler. Default is GCC *)
- let c99Mode = ref false (* True to handle ISO C 99 vs 90 changes.
- So far only affects integer parsing. *)
- (* Set this to true to get old-style handling of gcc's extern inline C extension:
- old-style: the extern inline definition is used until the actual definition is
- seen (as long as optimization is enabled)
- new-style: the extern inline definition is used only if there is no actual
- definition (as long as optimization is enabled)
- Note that CIL assumes that optimization is always enabled ;-) *)
- let oldstyleExternInline = ref false
- let makeStaticGlobal = ref true
- let useLogicalOperators = ref false
- let useComputedGoto = ref false
- let useCaseRange = ref false
- module M = Machdep
- (* Cil.initCil will set this to the current machine description.
- Makefile.cil generates the file src/machdep.ml,
- which contains the descriptions of gcc and msvc. *)
- let envMachine : M.mach option ref = ref None
- let lowerConstants: bool ref = ref true
- (** Do lower constants (default true) *)
- let insertImplicitCasts: bool ref = ref true
- (** Do insert implicit casts (default true) *)
- let little_endian = ref true
- let char_is_unsigned = ref false
- let underscore_name = ref false
- type lineDirectiveStyle =
- | LineComment (** Before every element, print the line
- * number in comments. This is ignored by
- * processing tools (thus errors are reproted
- * in the CIL output), but useful for
- * visual inspection *)
- | LineCommentSparse (** Like LineComment but only print a line
- * directive for a new source line *)
- | LinePreprocessorInput (** Use #line directives *)
- | LinePreprocessorOutput (** Use # nnn directives (in gcc mode) *)
- let lineDirectiveStyle = ref (Some LinePreprocessorInput)
-
- let print_CIL_Input = ref false
-
- let printCilAsIs = ref false
- let lineLength = ref 80
- let warnTruncate = ref true
-
- (* sm: return the string 's' if we're printing output for gcc, suppres
- * it if we're printing for CIL to parse back in. the purpose is to
- * hide things from gcc that it complains about, but still be able
- * to do lossless transformations when CIL is the consumer *)
- let forgcc (s: string) : string =
- if (!print_CIL_Input) then "" else s
- let debugConstFold = false
- (** The Abstract Syntax of CIL *)
- (** The top-level representation of a CIL source file. Its main contents is
- the list of global declarations and definitions. *)
- type file =
- { mutable fileName: string; (** The complete file name *)
- mutable globals: global list; (** List of globals as they will appear
- in the printed file *)
- mutable globinit: fundec option;
- (** An optional global initializer function. This is a function where
- * you can put stuff that must be executed before the program is
- * started. This function, is conceptually at the end of the file,
- * although it is not part of the globals list. Use {!Cil.getGlobInit}
- * to create/get one. *)
- mutable globinitcalled: bool;
- (** Whether the global initialization function is called in main. This
- should always be false if there is no global initializer. When
- you create a global initialization CIL will try to insert code in
- main to call it. *)
- }
- and comment = location * string
- (** The main type for representing global declarations and definitions. A list
- of these form a CIL file. The order of globals in the file is generally
- important. *)
- and global =
- | GType of typeinfo * location
- (** A typedef. All uses of type names (through the [TNamed] constructor)
- must be preceeded in the file by a definition of the name. The string
- is the defined name and always not-empty. *)
- | GCompTag of compinfo * location
- (** Defines a struct/union tag with some fields. There must be one of
- these for each struct/union tag that you use (through the [TComp]
- constructor) since this is the only context in which the fields are
- printed. Consequently nested structure tag definitions must be
- broken into individual definitions with the innermost structure
- defined first. *)
- | GCompTagDecl of compinfo * location
- (** Declares a struct/union tag. Use as a forward declaration. This is
- * printed without the fields. *)
- | GEnumTag of enuminfo * location
- (** Declares an enumeration tag with some fields. There must be one of
- these for each enumeration tag that you use (through the [TEnum]
- constructor) since this is the only context in which the items are
- printed. *)
- | GEnumTagDecl of enuminfo * location
- (** Declares an enumeration tag. Use as a forward declaration. This is
- * printed without the items. *)
- | GVarDecl of varinfo * location
- (** A variable declaration (not a definition). If the variable has a
- function type then this is a prototype. There can be several
- declarations and at most one definition for a given variable. If both
- forms appear then they must share the same varinfo structure. A
- prototype shares the varinfo with the fundec of the definition. Either
- has storage Extern or there must be a definition in this file *)
- | GVar of varinfo * initinfo * location
- (** A variable definition. Can have an initializer. The initializer is
- * updateable so that you can change it without requiring to recreate
- * the list of globals. There can be at most one definition for a
- * variable in an entire program. Cannot have storage Extern or function
- * type. *)
- | GFun of fundec * location
- (** A function definition. *)
- | GAsm of string * location (** Global asm statement. These ones
- can contain only a template *)
- | GPragma of attribute * location (** Pragmas at top level. Use the same
- syntax as attributes *)
- | GText of string (** Some text (printed verbatim) at
- top level. E.g., this way you can
- put comments in the output. *)
- (** The various types available. Every type is associated with a list of
- * attributes, which are always kept in sorted order. Use {!Cil.addAttribute}
- * and {!Cil.addAttributes} to construct list of attributes. If you want to
- * inspect a type, you should use {!Cil.unrollType} to see through the uses
- * of named types. *)
- and typ =
- TVoid of attributes (** Void type *)
- | TInt of ikind * attributes (** An integer type. The kind specifies
- the sign and width. *)
- | TFloat of fkind * attributes (** A floating-point type. The kind
- specifies the precision. *)
- | TPtr of typ * attributes
- (** Pointer type. *)
- | TArray of typ * exp option * attributes
- (** Array type. It indicates the base type and the array length. *)
- | TFun of typ * (string * typ * attributes) list option * bool * attributes
- (** Function type. Indicates the type of the result, the name, type
- * and name attributes of the formal arguments ([None] if no
- * arguments were specified, as in a function whose definition or
- * prototype we have not seen; [Some \[\]] means void). Use
- * {!Cil.argsToList} to obtain a list of arguments. The boolean
- * indicates if it is a variable-argument function. If this is the
- * type of a varinfo for which we have a function declaration then
- * the information for the formals must match that in the
- * function's sformals. *)
- | TNamed of typeinfo * attributes
- (** The use of a named type. All uses of the same type name must
- * share the typeinfo. Each such type name must be preceeded
- * in the file by a [GType] global. This is printed as just the
- * type name. The actual referred type is not printed here and is
- * carried only to simplify processing. To see through a sequence
- * of named type references, use {!Cil.unrollType}. The attributes
- * are in addition to those given when the type name was defined. *)
- | TComp of compinfo * attributes
- (** A reference to a struct or a union type. All references to the
- same struct or union must share the same compinfo among them and
- with a [GCompTag] global that preceeds all uses (except maybe
- those that are pointers to the composite type). The attributes
- given are those pertaining to this use of the type and are in
- addition to the attributes that were given at the definition of
- the type and which are stored in the compinfo. *)
- | TEnum of enuminfo * attributes
- (** A reference to an enumeration type. All such references must
- share the enuminfo among them and with a [GEnumTag] global that
- preceeds all uses. The attributes refer to this use of the
- enumeration and are in addition to the attributes of the
- enumeration itself, which are stored inside the enuminfo *)
-
- | TBuiltin_va_list of attributes
- (** This is the same as the gcc's type with the same name *)
- (** Various kinds of integers *)
- and ikind =
- IChar (** [char] *)
- | ISChar (** [signed char] *)
- | IUChar (** [unsigned char] *)
- | IBool (** [_Bool (C99)] *)
- | IInt (** [int] *)
- | IUInt (** [unsigned int] *)
- | IShort (** [short] *)
- | IUShort (** [unsigned short] *)
- | ILong (** [long] *)
- | IULong (** [unsigned long] *)
- | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *)
- | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft
- Visual C) *)
- (** Various kinds of floating-point numbers*)
- and fkind =
- FFloat (** [float] *)
- | FDouble (** [double] *)
- | FLongDouble (** [long double] *)
- (** An attribute has a name and some optional parameters *)
- and attribute = Attr of string * attrparam list
- (** Attributes are lists sorted by the attribute name *)
- and attributes = attribute list
- (** The type of parameters in attributes *)
- and attrparam =
- | AInt of int (** An integer constant *)
- | AStr of string (** A string constant *)
- | ACons of string * attrparam list (** Constructed attributes. These
- are printed [foo(a1,a2,...,an)].
- The list of parameters can be
- empty and in that case the
- parentheses are not printed. *)
- | ASizeOf of typ (** A way to talk about types *)
- | ASizeOfE of attrparam
- | ASizeOfS of typsig (** Replacement for ASizeOf in type
- signatures. Only used for
- attributes inside typsigs.*)
- | AAlignOf of typ
- | AAlignOfE of attrparam
- | AAlignOfS of typsig
- | AUnOp of unop * attrparam
- | ABinOp of binop * attrparam * attrparam
- | ADot of attrparam * string (** a.foo **)
- | AStar of attrparam (** * a *)
- | AAddrOf of attrparam (** & a **)
- | AIndex of attrparam * attrparam (** a1[a2] *)
- | AQuestion of attrparam * attrparam * attrparam (** a1 ? a2 : a3 **)
- (** Information about a composite type (a struct or a union). Use
- {!Cil.mkCompInfo}
- to create non-recursive or (potentially) recursive versions of this. Make
- sure you have a [GCompTag] for each one of these. *)
- and compinfo = {
- mutable cstruct: bool; (** True if struct, False if union *)
- mutable cname: string; (** The name. Always non-empty. Use
- * {!Cil.compFullName} to get the
- * full name of a comp (along with
- * the struct or union) *)
- mutable ckey: int; (** A unique integer constructed from
- * the name. Use {!Hashtbl.hash} on
- * the string returned by
- * {!Cil.compFullName}. All compinfo
- * for a given key are shared. *)
- mutable cfields: fieldinfo list; (** Information about the fields *)
- mutable cattr: attributes; (** The attributes that are defined at
- the same time as the composite
- type *)
- mutable cdefined: bool; (** Whether this is a defined
- * compinfo. *)
- mutable creferenced: bool; (** True if used. Initially set to
- * false *)
- }
- (** Information about a struct/union field *)
- and fieldinfo = {
- mutable fcomp: compinfo; (** The compinfo of the host. Note
- that this must be shared with the
- host since there can be only one
- compinfo for a given id *)
- mutable fname: string; (** The name of the field. Might be
- * the value of
- * {!Cil.missingFieldName} in which
- * case it must be a bitfield and is
- * not printed and it does not
- * participate in initialization *)
- mutable ftype: typ; (** The type *)
- mutable fbitfield: int option; (** If a bitfield then ftype should be
- an integer type *)
- mutable fattr: attributes; (** The attributes for this field
- * (not for its type) *)
- mutable floc: location; (** The location where this field
- * is defined *)
- }
- (** Information about an enumeration. This is shared by all references to an
- enumeration. Make sure you have a [GEnumTag] for each of of these. *)
- and enuminfo = {
- mutable ename: string; (** The name. Always non-empty *)
- mutable eitems: (string * exp * location) list; (** Items with names
- and values. This list
- should be
- non-empty. The item
- values must be
- compile-time
- constants. *)
- mutable eattr: attributes; (** Attributes *)
- mutable ereferenced: bool; (** True if used. Initially set to false*)
- mutable ekind: ikind;
- (** The integer kind used to represent this enum. Per ANSI-C, this
- * should always be IInt, but gcc allows other integer kinds *)
- }
- (** Information about a defined type *)
- and typeinfo = {
- mutable tname: string;
- (** The name. Can be empty only in a [GType] when introducing a composite
- * or enumeration tag. If empty cannot be refered to from the file *)
- mutable ttype: typ;
- (** The actual type. *)
- mutable treferenced: bool;
- (** True if used. Initially set to false*)
- }
- (** Information about a variable. These structures are shared by all
- * references to the variable. So, you can change the name easily, for
- * example. Use one of the {!Cil.makeLocalVar}, {!Cil.makeTempVar} or
- * {!Cil.makeGlobalVar} to create instances of this data structure. *)
- and varinfo = {
- mutable vname: string; (** The name of the variable. Cannot
- * be empty. *)
- mutable vtype: typ; (** The declared type of the
- * variable. *)
- mutable vattr: attributes; (** A list of attributes associated
- * with the variable. *)
- mutable vstorage: storage; (** The storage-class *)
- (* The other fields are not used in varinfo when they appear in the formal
- * argument list in a [TFun] type *)
- mutable vglob: bool; (** True if this is a global variable*)
- (** Whether this varinfo is for an inline function. *)
- mutable vinline: bool;
- mutable vdecl: location; (** Location of variable declaration *)
- vinit: initinfo;
- (** Optional initializer. Only used for static and global variables.
- * Initializers for other types of local variables are turned into
- * assignments. *)
- mutable vid: int; (** A unique integer identifier. *)
- mutable vaddrof: bool; (** True if the address of this
- variable is taken. CIL will set
- * these flags when it parses C, but
- * you should make sure to set the
- * flag whenever your transformation
- * create [AddrOf] expression. *)
- mutable vreferenced: bool; (** True if this variable is ever
- referenced. This is computed by
- [removeUnusedVars]. It is safe to
- just initialize this to False *)
- mutable vdescr: doc; (** For most temporary variables, a
- description of what the var holds.
- (e.g. for temporaries used for
- function call results, this string
- is a representation of the function
- call.) *)
- mutable vdescrpure: bool; (** Indicates whether the vdescr above
- is a pure expression or call.
- True for all CIL expressions and
- Lvals, but false for e.g. function
- calls.
- Printing a non-pure vdescr more
- than once may yield incorrect
- results. *)
- }
- (** Storage-class information *)
- and storage =
- NoStorage | (** The default storage. Nothing is
- * printed *)
- Static |
- Register |
- Extern
- (** Expressions (Side-effect free)*)
- and exp =
- Const of constant (** Constant *)
- | Lval of lval (** Lvalue *)
- | SizeOf of typ (** sizeof(<type>). Has [unsigned
- * int] type (ISO 6.5.3.4). This is
- * not turned into a constant because
- * some transformations might want to
- * change types *)
- | SizeOfE of exp (** sizeof(<expression>) *)
- | SizeOfStr of string
- (** sizeof(string_literal). We separate this case out because this is the
- * only instance in which a string literal should not be treated as
- * having type pointer to character. *)
- | AlignOf of typ (** Has [unsigned int] type *)
- | AlignOfE of exp
-
- | UnOp of unop * exp * typ (** Unary operation. Includes
- the type of the result *)
- | BinOp of binop * exp * exp * typ
- (** Binary operation. Includes the
- type of the result. The arithemtic
- conversions are made explicit
- for the arguments *)
- | Question of exp * exp * exp * typ
- (** (a ? b : c) operation. Includes
- the type of the result *)
- | CastE of typ * exp (** Use {!Cil.mkCast} to make casts *)
- | AddrOf of lval (** Always use {!Cil.mkAddrOf} to
- * construct one of these. Apply to an
- * lvalue of type [T] yields an
- * expression of type [TPtr(T)] *)
- | AddrOfLabel of stmt ref
- | StartOf of lval (** There is no C correspondent for this. C has
- * implicit coercions from an array to the address
- * of the first element. [StartOf] is used in CIL to
- * simplify type checking and is just an explicit
- * form of the above mentioned implicit conversion.
- * It is not printed. Given an lval of type
- * [TArray(T)] produces an expression of type
- * [TPtr(T)]. *)
- (** Literal constants *)
- and constant =
- | CInt64 of int64 * ikind * string option
- (** Integer constant. Give the ikind (see ISO9899 6.1.3.2)
- * and the textual representation, if available. Use
- * {!Cil.integer} or {!Cil.kinteger} to create these. Watch
- * out for integers that cannot be represented on 64 bits.
- * OCAML does not give Overflow exceptions. *)
- | CStr of string (** String constant (of pointer type) *)
- | CWStr of int64 list (** Wide string constant (of type "wchar_t *") *)
- | CChr of char (** Character constant. This has type int, so use
- * charConstToInt to read the value in case
- * sign-extension is needed. *)
- | CReal of float * fkind * string option (** Floating point constant. Give
- the fkind (see ISO 6.4.4.2) and
- also the textual representation,
- if available *)
- | CEnum of exp * string * enuminfo
- (** An enumeration constant with the given value, name, from the given
- * enuminfo. This is not used if {!Cil.lowerEnum} is false (default).
- * Use {!Cillower.lowerEnumVisitor} to replace these with integer
- * constants. *)
- (** Unary operators *)
- and unop =
- Neg (** Unary minus *)
- | BNot (** Bitwise complement (~) *)
- | LNot (** Logical Not (!) *)
- (** Binary operations *)
- and binop =
- PlusA (** arithmetic + *)
- | PlusPI (** pointer + integer *)
- | IndexPI (** pointer + integer but only when
- * it arises from an expression
- * [e\[i\]] when [e] is a pointer and
- * not an array. This is semantically
- * the same as PlusPI but CCured uses
- * this as a hint that the integer is
- * probably positive. *)
- | MinusA (** arithmetic - *)
- | MinusPI (** pointer - integer *)
- | MinusPP (** pointer - pointer *)
- | Mult (** * *)
- | Div (** / *)
- | Mod (** % *)
- | Shiftlt (** shift left *)
- | Shiftrt (** shift right *)
- | Lt (** < (arithmetic comparison) *)
- | Gt (** > (arithmetic comparison) *)
- | Le (** <= (arithmetic comparison) *)
- | Ge (** > (arithmetic comparison) *)
- | Eq (** == (arithmetic comparison) *)
- | Ne (** != (arithmetic comparison) *)
- | BAnd (** bitwise and *)
- | BXor (** exclusive-or *)
- | BOr (** inclusive-or *)
- | LAnd (** logical and *)
- | LOr (** logical or *)
- (** An lvalue denotes the contents of a range of memory addresses. This range
- * is denoted as a host object along with an offset within the object. The
- * host object can be of two kinds: a local or global variable, or an object
- * whose address is in a pointer expression. We distinguish the two cases so
- * that we can tell quickly whether we are accessing some component of a
- * variable directly or we are accessing a memory location through a pointer.*)
- and lval =
- lhost * offset
- (** The host part of an {!Cil.lval}. *)
- and lhost =
- | Var of varinfo
- (** The host is a variable. *)
- | Mem of exp
- (** The host is an object of type [T] when the expression has pointer
- * [TPtr(T)]. *)
- (** The offset part of an {!Cil.lval}. Each offset can be applied to certain
- * kinds of lvalues and its effect is that it advances the starting address
- * of the lvalue and changes the denoted type, essentially focussing to some
- * smaller lvalue that is contained in the original one. *)
- and offset =
- | NoOffset (** No offset. Can be applied to any lvalue and does
- * not change either the starting address or the type.
- * This is used when the lval consists of just a host
- * or as a terminator in a list of other kinds of
- * offsets. *)
- | Field of fieldinfo * offset
- (** A field offset. Can be applied only to an lvalue
- * that denotes a structure or a union that contains
- * the mentioned field. This advances the offset to the
- * beginning of the mentioned field and changes the
- * type to the type of the mentioned field. *)
- | Index of exp * offset
- (** An array index offset. Can be applied only to an
- * lvalue that denotes an array. This advances the
- * starting address of the lval to the beginning of the
- * mentioned array element and changes the denoted type
- * to be the type of the array element *)
- (* The following equivalences hold *)
- (* Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off *)
- (* Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off *)
- (* AddrOf (Mem a, NoOffset) = a *)
- (** Initializers for global variables. You can create an initializer with
- * {!Cil.makeZeroInit}. *)
- and init =
- | SingleInit of exp (** A single initializer *)
- | CompoundInit of typ * (offset * init) list
- (** Used only for initializers of structures, unions and arrays.
- * The offsets are all of the form [Field(f, NoOffset)] or
- * [Index(i, NoOffset)] and specify the field or the index being
- * initialized. For structures all fields
- * must have an initializer (except the unnamed bitfields), in
- * the proper order. This is necessary since the offsets are not
- * printed. For arrays the list must contain a prefix of the
- * initializers; the rest are 0-initialized.
- * For unions there must be exactly one initializer. If
- * the initializer is not for the first field then a field
- * designator is printed, so you better be on GCC since MSVC does
- * not understand this. You can scan an initializer list with
- * {!Cil.foldLeftCompound}. *)
- (** We want to be able to update an initializer in a global variable, so we
- * define it as a mutable field *)
- and initinfo = {
- mutable init : init option;
- }
- (** Function definitions. *)
- and fundec =
- { mutable svar: varinfo;
- (** Holds the name and type as a variable, so we can refer to it
- * easily from the program. All references to this function either
- * in a function call or in a prototype must point to the same
- * varinfo. *)
- mutable sformals: varinfo list;
- (** Formals. These must be shared with the formals that appear in the
- * type of the function. Use {!Cil.setFormals} or
- * {!Cil.setFunctionType} to set these
- * formals and ensure that they are reflected in the function type.
- * Do not make copies of these because the body refers to them. *)
- mutable slocals: varinfo list;
- (** Locals. Does not include the sformals. Do not make copies of
- * these because the body refers to them. *)
- mutable smaxid: int; (** Max local id. Starts at 0. *)
- mutable sbody: block; (** The function body. *)
- mutable smaxstmtid: int option; (** max id of a (reachable) statement
- * in this function, if we have
- * computed it. range = 0 ...
- * (smaxstmtid-1). This is computed by
- * {!Cil.computeCFGInfo}. *)
- mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo}
- * this field is set to contain all
- * statements in the function *)
- }
- (** A block is a sequence of statements with the control falling through from
- one element to the next *)
- and block =
- { mutable battrs: attributes; (** Attributes for the block *)
- mutable bstmts: stmt list; (** The statements comprising the block*)
- }
- (** Statements.
- The statement is the structural unit in the control flow graph. Use mkStmt
- to make a statement and then fill in the fields. *)
- and stmt = {
- mutable labels: label list; (** Whether the statement starts with
- some labels, case statements or
- default statement *)
- mutable skind: stmtkind; (** The kind of statement *)
- (* Now some additional control flow information. Initially this is not
- * filled in. *)
- mutable sid: int; (** A number (>= 0) that is unique
- in a function. *)
- mutable succs: stmt list; (** The successor statements. They can
- always be computed from the skind
- and the context in which this
- statement appears *)
- mutable preds: stmt list; (** The inverse of the succs function*)
- }
- (** Labels *)
- and label =
- Label of string * location * bool
- (** A real label. If the bool is "true", the label is from the
- * input source program. If the bool is "false", the label was
- * created by CIL or some other transformation *)
- | Case of exp * location (** A case statement *)
- | CaseRange of exp * exp * location (** A case statement corresponding to a
- range of values *)
- | Default of location (** A default statement *)
- (* The various kinds of statements *)
- and stmtkind =
- | Instr of instr list (** A group of instructions that do not
- contain control flow. Control
- implicitly falls through. *)
- | Return of exp option * location (** The return statement. This is a
- leaf in the CFG. *)
- | Goto of stmt ref * location (** A goto statement. Appears from
- actual goto's in the code. *)
- | ComputedGoto of exp * location
- | Break of location (** A break to the end of the nearest
- enclosing Loop or Switch *)
- | Continue of location (** A continue to the start of the
- nearest enclosing [Loop] *)
- | If of exp * block * block * location (** A conditional.
- Two successors, the "then" and
- the "else" branches. Both
- branches fall-through to the
- successor of the If statement *)
- | Switch of exp * block * (stmt list) * location
- (** A switch statement. The block
- contains within all of the cases.
- We also have direct pointers to the
- statements that implement the
- cases. Which cases they implement
- you can get from the labels of the
- statement *)
- | Loop of block * location * (stmt option) * (stmt option)
- (** A [while(1)] loop. The
- * termination test is implemented
- * in the body of a loop using a
- * [Break] statement. If
- * prepareCFG has been called, the
- * first stmt option will point to
- * the stmt containing the
- * continue label for this loop
- * and the second will point to
- * the stmt containing the break
- * label for this loop. *)
- | Block of block (** Just a block of statements. Use it
- as a way to keep some attributes
- local *)
- (** On MSVC we support structured exception handling. This is what you
- * might expect. Control can get into the finally block either from the
- * end of the body block, or if an exception is thrown. The location
- * corresponds to the try keyword. *)
- | TryFinally of block * block * location
- (** On MSVC we support structured exception handling. The try/except
- * statement is a bit tricky:
- __try { blk }
- __except (e) {
- handler
- }
- The argument to __except must be an expression. However, we keep a
- list of instructions AND an expression in case you need to make
- function calls. We'll print those as a comma expression. The control
- can get to the __except expression only if an exception is thrown.
- After that, depending on the value of the expression the control
- goes to the handler, propagates the exception, or retries the
- exception !!! The location corresponds to the try keyword.
- *)
- | TryExcept of block * (instr list * exp) * block * location
-
- (** Instructions. They may cause effects directly but may not have control
- flow.*)
- and instr =
- Set of lval * exp * location (** An assignment. A cast is present
- if the exp has different type
- from lval *)
- | Call of lval option * exp * exp list * location
- (** optional: result is an lval. A cast might be
- necessary if the declared result type of the
- function is not the same as that of the
- destination. If the function is declared then
- casts are inserted for those arguments that
- correspond to declared formals. (The actual
- number of arguments might be smaller or larger
- than the declared number of arguments. C allows
- this.) If the type of the result variable is not
- the same as the declared type of the function
- result then an implicit cast exists. *)
- (* See the GCC specification for the meaning of ASM.
- * If the source is MS VC then only the templates
- * are used *)
- (* sm: I've added a notes.txt file which contains more
- * information on interpreting Asm instructions *)
- | Asm of attributes * (* Really only const and volatile can appear
- * here *)
- string list * (* templates (CR-separated) *)
- (string option * string * lval) list *
- (* outputs must be lvals with
- * optional names and constraints.
- * I would like these
- * to be actually variables, but I
- * run into some trouble with ASMs
- * in the Linux sources *)
- (string option * string * exp) list *
- (* inputs with optional names and constraints *)
- string list * (* register clobbers *)
- location
- (** An inline assembly instruction. The arguments are (1) a list of
- attributes (only const and volatile can appear here and only for
- GCC), (2) templates (CR-separated), (3) a list of
- outputs, each of which is an lvalue with a constraint, (4) a list
- of input expressions along with constraints, (5) clobbered
- registers, and (5) location information *)
- (** Describes a location in a source file *)
- and location = {
- line: int; (** The line number. -1 means "do not know" *)
- file: string; (** The name of the source file*)
- byte: int; (** The byte position in the source file *)
- }
- (* Type signatures. Two types are identical iff they have identical
- * signatures *)
- and typsig =
- TSArray of typsig * int64 option * attribute list
- | TSPtr of typsig * attribute list
- | TSComp of bool * string * attribute list
- | TSFun of typsig * typsig list option * bool * attribute list
- | TSEnum of string * attribute list
- | TSBase of typ
- let locUnknown = { line = -1;
- file = "";
- byte = -1;}
- (* A reference to the current location *)
- let currentLoc : location ref = ref locUnknown
- (* A reference to the current global being visited *)
- let currentGlobal: global ref = ref (GText "dummy")
- let compareLoc (a: location) (b: location) : int =
- let namecmp = compare a.file b.file in
- if namecmp != 0
- then namecmp
- else
- let linecmp = a.line - b.line in
- if linecmp != 0
- then linecmp
- else a.byte - b.byte
- let argsToList : (string * typ * attributes) list option
- -> (string * typ * attributes) list
- = function
- None -> []
- | Some al -> al
- (* A hack to allow forward reference of d_exp *)
- let pd_exp : (unit -> exp -> doc) ref =
- ref (fun _ -> E.s (E.bug "pd_exp not initialized"))
- let pd_type : (unit -> typ -> doc) ref =
- ref (fun _ -> E.s (E.bug "pd_type not initialized"))
- let pd_attr : (unit -> attribute -> doc) ref =
- ref (fun _ -> E.s (E.bug "pd_attr not initialized"))
- (** Different visiting actions. 'a will be instantiated with [exp], [instr],
- etc. *)
- type 'a visitAction =
- SkipChildren (** Do not visit the children. Return
- the node as it is. *)
- | DoChildren (** Continue with the children of this
- node. Rebuild the node on return
- if any of the children changes
- (use == test) *)
- | ChangeTo of 'a (** Replace the expression with the
- given one *)
- | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
- exp is replaced by the first
- parameter. Then continue with
- the children. On return rebuild
- the node if any of the children
- has changed and then apply the
- function on the node *)
- (* sm/gn: cil visitor interface for traversing Cil trees. *)
- (* Use visitCilStmt and/or visitCilFile to use this. *)
- (* Some of the nodes are changed in place if the children are changed. Use
- * one of Change... actions if you want to copy the node *)
- (** A visitor interface for traversing CIL trees. Create instantiations of
- * this type by specializing the class {!Cil.nopCilVisitor}. *)
- class type cilVisitor = object
- method vvdec: varinfo -> varinfo visitAction
- (** Invoked for each variable declaration. The subtrees to be traversed
- * are those corresponding to the type and attributes of the variable.
- * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
- * all the [varinfo] in formals of function types, and the formals and
- * locals for function definitions. This means that the list of formals
- * in a function definition will be traversed twice, once as part of the
- * function type and second as part of the formals in a function
- * definition. *)
- method vvrbl: varinfo -> varinfo visitAction
- (** Invoked on each variable use. Here only the [SkipChildren] and
- * [ChangeTo] actions make sense since there are no subtrees. Note that
- * the type and attributes of the variable are not traversed for a
- * variable use *)
- method vexpr: exp -> exp visitAction
- (** Invoked on each expression occurence. The subtrees are the
- * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
- * variable use. *)
- method vlval: lval -> lval visitAction
- (** Invoked on each lvalue occurence *)
- method voffs: offset -> offset visitAction
- (** Invoked on each offset occurrence that is *not* as part
- * of an initializer list specification, i.e. in an lval or
- * recursively inside an offset. *)
- method vinitoffs: offset -> offset visitAction
- (** Invoked on each offset appearing in the list of a
- * CompoundInit initializer. *)
- method vinst: instr -> instr list visitAction
- (** Invoked on each instruction occurrence. The [ChangeTo] action can
- * replace this instruction with a list of instructions *)
- method vstmt: stmt -> stmt visitAction
- (** Control-flow statement. *)
- method vblock: block -> block visitAction (** Block. Replaced in
- place. *)
- method vfunc: fundec -> fundec visitAction (** Function definition.
- Replaced in place. *)
- method vglob: global -> global list visitAction (** Global (vars, types,
- etc.) *)
- method vinit: varinfo -> offset -> init -> init visitAction
- (** Initializers for globals,
- * pass the global where this
- * occurs, and the offset *)
- method vtype: typ -> typ visitAction (** Use of some type. Note
- * that for structure/union
- * and enumeration types the
- * definition of the
- * composite type is not
- * visited. Use [vglob] to
- * visit it. *)
- method vattr: attribute -> attribute list visitAction
- (** Attribute. Each attribute can be replaced by a list *)
- method vattrparam: attrparam -> attrparam visitAction
- (** Attribute parameters. *)
- (** Add here instructions while visiting to queue them to
- * preceede the current statement or instruction being processed *)
- method queueInstr: instr list -> unit
- (** Gets the queue of instructions and resets the queue *)
- method unqueueInstr: unit -> instr list
- end
- (* the default visitor does nothing at each node, but does *)
- (* not stop; hence they return true *)
- class nopCilVisitor : cilVisitor = object
- method vvrbl (v:varinfo) = DoChildren (* variable *)
- method vvdec (v:varinfo) = DoChildren (* variable
- * declaration *)
- method vexpr (e:exp) = DoChildren (* expression *)
- method vlval (l:lval) = DoChildren (* lval (base is 1st
- * field) *)
- method voffs (o:offset) = DoChildren (* lval or recursive offset *)
- method vinitoffs (o:offset) = DoChildren (* initializer offset *)
- method vinst (i:instr) = DoChildren (* imperative instruction *)
- method vstmt (s:stmt) = DoChildren (* constrol-flow statement *)
- method vblock (b: block) = DoChildren
- method vfunc (f:fundec) = DoChildren (* function definition *)
- method vglob (g:global) = DoChildren (* global (vars, types, etc.) *)
- method vinit (forg: varinfo) (off: offset) (i:init) = DoChildren (* global initializers *)
- method vtype (t:typ) = DoChildren (* use of some type *)
- method vattr (a: attribute) = DoChildren
- method vattrparam (a: attrparam) = DoChildren
- val mutable instrQueue = []
-
- method queueInstr (il: instr list) =
- List.iter (fun i -> instrQueue <- i :: instrQueue) il
- method unqueueInstr () =
- let res = List.rev instrQueue in
- instrQueue <- [];
- res
- end
- let assertEmptyQueue vis =
- if vis#unqueueInstr () <> [] then
- (* Either a visitor inserted an instruction somewhere that it shouldn't
- have (i.e. at the top level rather than inside of a statement), or
- there's a bug in the visitor engine. *)
- E.s (E.bug "Visitor's instruction queue is not empty.\n You should only use queueInstr inside a function body!");
- ()
- let lu = locUnknown
- (* sm: utility *)
- let startsWith (prefix: string) (s: string) : bool =
- (
- let prefixLen = (String.length prefix) in
- (String.length s) >= prefixLen &&
- (String.sub s 0 prefixLen) = prefix
- )
- let endsWith (suffix: string) (s: string) : bool =
- let suffixLen = String.length suffix in
- let sLen = String.length s in
- sLen >= suffixLen &&
- (String.sub s (sLen - suffixLen) suffixLen) = suffix
- let stripUnderscores (s: string) : string =
- if (startsWith "__" s) && (endsWith "__" s) then
- String.sub s 2 ((String.length s) - 4)
- else
- s
- let get_instrLoc (inst : instr) =
- match inst with
- Set(_, _, loc) -> loc
- | Call(_, _, _, loc) -> loc
- | Asm(_, _, _, _, _, loc) -> loc
- let get_globalLoc (g : global) =
- match g with
- | GFun(_,l) -> (l)
- | GType(_,l) -> (l)
- | GEnumTag(_,l) -> (l)
- | GEnumTagDecl(_,l) -> (l)
- | GCompTag(_,l) -> (l)
- | GCompTagDecl(_,l) -> (l)
- | GVarDecl(_,l) -> (l)
- | GVar(_,_,l) -> (l)
- | GAsm(_,l) -> (l)
- | GPragma(_,l) -> (l)
- | GText(_) -> locUnknown
- let rec get_stmtLoc (statement : stmtkind) =
- match statement with
- Instr([]) -> lu
- | Instr(hd::tl) -> get_instrLoc(hd)
- | Return(_, loc) -> loc
- | Goto(_, loc) -> loc
- | ComputedGoto(_, loc) -> loc
- | Break(loc) -> loc
- | Continue(loc) -> loc
- | If(_, _, _, loc) -> loc
- | Switch (_, _, _, loc) -> loc
- | Loop (_, loc, _, _) -> loc
- | Block b -> if b.bstmts == [] then lu
- else get_stmtLoc ((List.hd b.bstmts).skind)
- | TryFinally (_, _, l) -> l
- | TryExcept (_, _, _, l) -> l
- (* The next variable identifier to use. Counts up *)
- let nextGlobalVID = ref 1
- (* The next compindo identifier to use. Counts up. *)
- let nextCompinfoKey = ref 1
- (* Some error reporting functions *)
- let d_loc (_: unit) (loc: location) : doc =
- text loc.file ++ chr ':' ++ num loc.line
- let d_thisloc (_: unit) : doc = d_loc () !currentLoc
- let error (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- E.hadErrors := true;
- ignore (eprintf "%t: Error: %a@!"
- d_thisloc insert d);
- nil
- in
- Pretty.gprintf f fmt
- let unimp (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- E.hadErrors := true;
- ignore (eprintf "%t: Unimplemented: %a@!"
- d_thisloc insert d);
- nil
- in
- Pretty.gprintf f fmt
- let bug (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- E.hadErrors := true;
- ignore (eprintf "%t: Bug: %a@!"
- d_thisloc insert d);
- E.showContext ();
- nil
- in
- Pretty.gprintf f fmt
- let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- E.hadErrors := true;
- ignore (eprintf "%a: Error: %a@!"
- d_loc loc insert d);
- E.showContext ();
- nil
- in
- Pretty.gprintf f fmt
- let warn (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- ignore (eprintf "%t: Warning: %a@!"
- d_thisloc insert d);
- nil
- in
- Pretty.gprintf f fmt
- let warnOpt (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- if !E.warnFlag then
- ignore (eprintf "%t: Warning: %a@!"
- d_thisloc insert d);
- nil
- in
- Pretty.gprintf f fmt
- let warnContext (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- ignore (eprintf "%t: Warning: %a@!"
- d_thisloc insert d);
- E.showContext ();
- nil
- in
- Pretty.gprintf f fmt
- let warnContextOpt (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- if !E.warnFlag then
- ignore (eprintf "%t: Warning: %a@!"
- d_thisloc insert d);
- E.showContext ();
- nil
- in
- Pretty.gprintf f fmt
- let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a =
- let f d =
- ignore (eprintf "%a: Warning: %a@!"
- d_loc loc insert d);
- E.showContext ();
- nil
- in
- Pretty.gprintf f fmt
- let zero = Const(CInt64(Int64.zero, IInt, None))
- (** Given the character c in a (CChr c), sign-extend it to 32 bits.
- (This is the official way of interpreting character constants, according to
- ISO C 6.4.4.4.10, which says that character constants are chars cast to ints)
- Returns CInt64(sign-extened c, IInt, None) *)
- let charConstToInt (c: char) : constant =
- let c' = Char.code c in
- let value =
- if c' < 128
- then Int64.of_int c'
- else Int64.of_int (c' - 256)
- in
- CInt64(value, IInt, None)
-
-
- (** Convert a 64-bit int to an OCaml int, or raise an exception if that
- can't be done. *)
- let i64_to_int (i: int64) : int =
- let i': int = Int64.to_int i in (* i.e. i' = i mod 2^31 *)
- if i = Int64.of_int i' then i'
- else E.s (E.unimp "%a: Int constant too large: %Ld\n" d_loc !currentLoc i)
- let cilint_to_int (i: cilint) : int =
- try int_of_cilint i
- with _ -> E.s (E.unimp "%a: Int constant too large: %s\n"
- d_loc !currentLoc (string_of_cilint i))
- let voidType = TVoid([])
- let intType = TInt(IInt,[])
- let uintType = TInt(IUInt,[])
- let longType = TInt(ILong,[])
- let ulongType = TInt(IULong,[])
- let charType = TInt(IChar, [])
- let boolType = TInt(IBool, [])
- let charPtrType = TPtr(charType,[])
- let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[])
- let stringLiteralType = ref charPtrType
- let voidPtrType = TPtr(voidType, [])
- let intPtrType = TPtr(intType, [])
- let uintPtrType = TPtr(uintType, [])
- let boolPtrType = TPtr(boolType, [])
- let doubleType = TFloat(FDouble, [])
- (* An integer type that fits pointers. Initialized by initCIL *)
- let upointType = ref voidType
- (* An integer type that fits a pointer difference. Initialized by initCIL *)
- let ptrdiffType = ref voidType
- (* An integer type that fits wchar_t. Initialized by initCIL *)
- let wcharKind = ref IChar
- let wcharType = ref voidType
- (* An integer type that is the type of sizeof. Initialized by initCIL *)
- let typeOfSizeOf = ref voidType
- let kindOfSizeOf = ref IUInt
- let initCIL_called = ref false
- (** Returns true if and only if the given integer type is signed. *)
- let isSigned = function
- | IBool
- | IUChar
- | IUShort
- | IUInt
- | IULong
- | IULongLong ->
- false
- | ISChar
- | IShort
- | IInt
- | ILong
- | ILongLong ->
- true
- | IChar ->
- not !M.theMachine.M.char_is_unsigned
- let mkStmt (sk: stmtkind) : stmt =
- { skind = sk;
- labels = [];
- sid = -1; succs = []; preds = [] }
- let mkBlock (slst: stmt list) : block =
- { battrs = []; bstmts = slst; }
- let mkEmptyStmt () = mkStmt (Instr [])
- let mkStmtOneInstr (i: instr) = mkStmt (Instr [i])
- let dummyInstr = (Asm([], ["dummy statement!!"], [], [], [], lu))
- let dummyStmt = mkStmt (Instr [dummyInstr])
- let compactStmts (b: stmt list) : stmt list =
- (* Try to compress statements. Scan the list of statements and remember
- * the last instrunction statement encountered, along with a Clist of
- * instructions in it. *)
- let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *)
- (lastinstrs: instr Clist.clist)
- (body: stmt list) =
- let finishLast (tail: stmt list) : stmt list =
- if lastinstrstmt == dummyStmt then tail
- else begin
- lastinstrstmt.skind <- Instr (Clist.toList lastinstrs);
- lastinstrstmt :: tail
- end
- in
- match body with
- [] -> finishLast []
- | ({skind=Instr il} as s) :: rest ->
- let ils = Clist.fromList il in
- if lastinstrstmt != dummyStmt && s.labels == [] then
- compress lastinstrstmt (Clist.append lastinstrs ils) rest
- else
- finishLast (compress s ils rest)
- | {skind=Block b;labels = []} :: rest when b.battrs = [] ->
- compress lastinstrstmt lastinstrs (b.bstmts@rest)
- | s :: rest ->
- let res = s :: compress dummyStmt Clist.empty rest in
- finishLast res
- in
- compress dummyStmt Clist.empty b
- (** Construct sorted lists of attributes ***)
- let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) =
- let rec insertSorted = function
- [] -> [a]
- | ((Attr(an0, _) as a0) :: rest) as l ->
- if an < an0 then a :: l
- else if Util.equals a a0 then l (* Do not add if already in there *)
- else a0 :: insertSorted rest (* Make sure we see all attributes with
- * this name *)
- in
- insertSorted al
- (** The second attribute list is sorted *)
- and addAttributes al0 (al: attributes) : attributes =
- if al0 == [] then al else
- List.fold_left (fun acc a -> addAttribute a acc) al al0
- and dropAttribute (an: string) (al: attributes) =
- List.filter (fun (Attr(an', _)) -> an <> an') al
- and dropAttributes (anl: string list) (al: attributes) =
- List.fold_left (fun acc an -> dropAttribute an acc) al anl
-
- and filterAttributes (s: string) (al: attribute list) : attribute list =
- List.filter (fun (Attr(an, _)) -> an = s) al
- (* sm: *)
- let hasAttribute s al =
- (filterAttributes s al <> [])
- type attributeClass =
- AttrName of bool
- (* Attribute of a name. If argument is true and we are on MSVC then
- * the attribute is printed using __declspec as part of the storage
- * specifier *)
- | AttrFunType of bool
- (* Attribute of a function type. If argument is true and we are on
- * MSVC then the attribute is printed just before the function name *)
- | AttrType (* Attribute of a type *)
- (* This table contains the mapping of predefined attributes to classes.
- * Extend this table with more attributes as you need. This table is used to
- * determine how to associate attributes with names or type during cabs2cil
- * conversion *)
- let attributeHash: (string, attributeClass) H.t =
- let table = H.create 13 in
- List.iter (fun a -> H.add table a (AttrName false))
- [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak";
- "no_instrument_function"; "alias"; "no_check_memory_usage";
- "exception"; "model"; (* "restrict"; *)
- "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in
- * assembly for a global *)];
- (* Now come the MSVC declspec attributes *)
- List.iter (fun a -> H.add table a (AttrName true))
- [ "thread"; "naked"; "dllimport"; "dllexport";
- "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn";
- "uuid"; "align" ];
- List.iter (fun a -> H.add table a (AttrFunType false))
- [ "format"; "regparm"; "longcall";
- "noinline"; "always_inline"; "gnu_inline"; "leaf";
- "artificial"; "warn_unused_result"; "nonnull";
- ];
- List.iter (fun a -> H.add table a (AttrFunType true))
- [ "stdcall";"cdecl"; "fastcall" ];
- List.iter (fun a -> H.add table a AttrType)
- [ "const"; "volatile"; "restrict"; "mode" ];
- table
-
- (* Partition the attributes into classes *)
- let partitionAttributes
- ~(default:attributeClass)
- (attrs: attribute list) :
- attribute list * attribute list * attribute list =
- let rec loop (n,f,t) = function
- [] -> n, f, t
- | (Attr(an, _) as a) :: rest ->
- match (try H.find attributeHash an with Not_found -> default) with
- AttrName _ -> loop (addAttribute a n, f, t) rest
- | AttrFunType _ ->
- loop (n, addAttribute a f, t) rest
- | AttrType -> loop (n, f, addAttribute a t) rest
- in
- loop ([], [], []) attrs
- (* Get the full name of a comp *)
- let compFullName comp =
- (if comp.cstruct then "struct " else "union ") ^ comp.cname
-
- let missingFieldName = "___missing_field_name"
- (** Creates a a (potentially recursive) composite type. Make sure you add a
- * GTag for it to the file! **)
- let mkCompInfo
- (isstruct: bool)
- (n: string)
- (* fspec is a function that when given a forward
- * representation of the structure type constructs the type of
- * the fields. The function can ignore this argument if not
- * constructing a recursive type. *)
- (mkfspec: compinfo -> (string * typ * int option * attribute list *
- location) list)
- (a: attribute list) : compinfo =
- (* make a new name for anonymous structs *)
- if n = "" then
- E.s (E.bug "mkCompInfo: missing structure name\n");
- (* Make a new self cell and a forward reference *)
- let comp =
- { cstruct = isstruct; cname = ""; ckey = 0; cfields = [];
- cattr = a; creferenced = false;
- (* Make this compinfo undefined by default *)
- cdefined = false; }
- in
- comp.cname <- n;
- comp.ckey <- !nextCompinfoKey;
- incr nextCompinfoKey;
- let flds =
- Util.list_map (fun (fn, ft, fb, fa, fl) ->
- { fcomp = comp;
- ftype = ft;
- fname = fn;
- fbitfield = fb;
- fattr = fa;
- floc = fl}) (mkfspec comp) in
- comp.cfields <- flds;
- if flds <> [] then comp.cdefined <- true;
- comp
- (** Make a copy of a compinfo, changing the name and the key *)
- let copyCompInfo (ci: compinfo) (n: string) : compinfo =
- let ci' = {ci with cname = n;
- ckey = !nextCompinfoKey; } in
- incr nextCompinfoKey;
- (* Copy the fields and set the new pointers to parents *)
- ci'.cfields <- Util.list_map (fun f -> {f with fcomp = ci'}) ci'.cfields;
- ci'
- (**** Utility functions ******)
- let rec typeAttrs = function
- TVoid a -> a
- | TInt (_, a) -> a
- | TFloat (_, a) -> a
- | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
- | TPtr (_, a) -> a
- | TArray (_, _, a) -> a
- | TComp (comp, a) -> addAttributes comp.cattr a
- | TEnum (enum, a) -> addAttributes enum.eattr a
- | TFun (_, _, _, a) -> a
- | TBuiltin_va_list a -> a
- let setTypeAttrs t a =
- match t with
- TVoid _ -> TVoid a
- | TInt (i, _) -> TInt (i, a)
- | TFloat (f, _) -> TFloat (f, a)
- | TNamed (t, _) -> TNamed(t, a)
- | TPtr (t', _) -> TPtr(t', a)
- | TArray (t', l, _) -> TArray(t', l, a)
- | TComp (comp, _) -> TComp (comp, a)
- | TEnum (enum, _) -> TEnum (enum, a)
- | TFun (r, args, v, _) -> TFun(r,args,v,a)
- | TBuiltin_va_list _ -> TBuiltin_va_list a
- let typeAddAttributes a0 t =
- begin
- match a0 with
- | [] ->
- (* no attributes, keep same type *)
- t
- | _ ->
- (* anything else: add a0 to existing attributes *)
- let add (a: attributes) = addAttributes a0 a in
- match t with
- TVoid a -> TVoid (add a)
- | TInt (ik, a) -> TInt (ik, add a)
- | TFloat (fk, a) -> TFloat (fk, add a)
- | TEnum (enum, a) -> TEnum (enum, add a)
- | TPtr (t, a) -> TPtr (t, add a)
- | TArray (t, l, a) -> TArray (t, l, add a)
- | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
- | TComp (comp, a) -> TComp (comp, add a)
- | TNamed (t, a) -> TNamed (t, add a)
- | TBuiltin_va_list a -> TBuiltin_va_list (add a)
- end
- let typeRemoveAttributes (anl: string list) t =
- let drop (al: attributes) = dropAttributes anl al in
- match t with
- TVoid a -> TVoid (drop a)
- | TInt (ik, a) -> TInt (ik, drop a)
- | TFloat (fk, a) -> TFloat (fk, drop a)
- | TEnum (enum, a) -> TEnum (enum, drop a)
- | TPtr (t, a) -> TPtr (t, drop a)
- | TArray (t, l, a) -> TArray (t, l, drop a)
- | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a)
- | TComp (comp, a) -> TComp (comp, drop a)
- | TNamed (t, a) -> TNamed (t, drop a)
- | TBuiltin_va_list a -> TBuiltin_va_list (drop a)
- let unrollType (t: typ) : typ =
- let rec withAttrs (al: attributes) (t: typ) : typ =
- match t with
- TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
- | x -> typeAddAttributes al x
- in
- withAttrs [] t
- let rec unrollTypeDeep (t: typ) : typ =
- let rec withAttrs (al: attributes) (t: typ) : typ =
- match t with
- TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
- | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a')
- | TArray(t, l, a') -> TArray(unrollTypeDeep t, l, addAttributes al a')
- | TFun(rt, args, isva, a') ->
- TFun (unrollTypeDeep rt,
- (match args with
- None -> None
- | Some argl ->
- Some (Util.list_map (fun (an,at,aa) ->
- (an, unrollTypeDeep at, aa)) argl)),
- isva,
- addAttributes al a')
- | x -> typeAddAttributes al x
- in
- withAttrs [] t
- let isVoidType t =
- match unrollType t with
- TVoid _ -> true
- | _ -> false
- let isVoidPtrType t =
- match unrollType t with
- TPtr(tau,_) when isVoidType tau -> true
- | _ -> false
- let var vi : lval = (Var vi, NoOffset)
- (* let assign vi e = Instrs(Set (var vi, e), lu) *)
- let mkString s = Const(CStr s)
- let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list =
- (* Do it like this so that the pretty printer recognizes it *)
- [ mkStmt (Loop (mkBlock (mkStmt (If(guard,
- mkBlock [ mkEmptyStmt () ],
- mkBlock [ mkStmt (Break lu)], lu)) ::
- body), lu, None, None)) ]
- let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
- ~(body: stmt list) : stmt list =
- (start @
- (mkWhile guard (body @ next)))
-
- let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp)
- ~(body: stmt list) : stmt list =
- (* See what kind of operator we need *)
- let compop, nextop =
- match unrollType iter.vtype with
- TPtr _ -> Lt, PlusPI
- | _ -> Lt, PlusA
- in
- mkFor
- [ mkStmt (Instr [(Set (var iter, first, lu))]) ]
- (BinOp(compop, Lval(var iter), past, intType))
- [ mkStmt (Instr [(Set (var iter,
- (BinOp(nextop, Lval(var iter), incr, iter.vtype)),
- lu))])]
- body
-
- let rec stripCasts (e: exp) =
- match e with CastE(_, e') -> stripCasts e' | _ -> e
- (* the name of the C function we call to get ccgr ASTs
- external parse : string -> file = "cil_main"
- *)
- (*
- Pretty Printing
- *)
- let d_ikind () = function
- IChar -> text "char"
- | ISChar -> text "signed char"
- | IUChar -> text "unsigned char"
- | IBool -> text "_Bool"
- | IInt -> text "int"
- | IUInt -> text "unsigned int"
- | IShort -> text "short"
- | IUShort -> text "unsigned short"
- | ILong -> text "long"
- | IULong -> text "unsigned long"
- | ILongLong ->
- if !msvcMode then text "__int64" else text "long long"
- | IULongLong ->
- if !msvcMode then text "unsigned __int64"
- else text "unsigned long long"
- let d_fkind () = function
- FFloat -> text "float"
- | FDouble -> text "double"
- | FLongDouble -> text "long double"
- let d_storage () = function
- NoStorage -> nil
- | Static -> text "static "
- | Extern -> text "extern "
- | Register -> text "register "
- (* sm: need this value below *)
- let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000")
- let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000")
- let bytesSizeOfInt (ik: ikind): int =
- match ik with
- | IChar | ISChar | IUChar -> 1
- | IBool -> !M.theMachine.M.sizeof_bool
- | IInt | IUInt -> !M.theMachine.M.sizeof_int
- | IShort | IUShort -> !M.theMachine.M.sizeof_short
- | ILong | IULong -> !M.theMachine.M.sizeof_long
- | ILongLong | IULongLong -> !M.theMachine.M.sizeof_longlong
- (* constant *)
- let d_const () c =
- match c with
- CInt64(_, _, Some s) -> text s (* Always print the text if there is one *)
- | CInt64(i, ik, None) ->
- (** We must make sure to capture the type of the constant. For some
- * constants this is done with a suffix, for others with a cast prefix.*)
- let suffix : string =
- match ik with
- IUInt -> "U"
- | ILong -> "L"
- | IULong -> "UL"
- | ILongLong -> if !msvcMode then "L" else "LL"
- | IULongLong -> if !msvcMode then "UL" else "ULL"
- | _ -> ""
- in
- let prefix : string =
- if suffix <> "" then ""
- else if ik = IInt then ""
- else "(" ^ (sprint !lineLength (d_ikind () ik)) ^ ")"
- in
- (* Watch out here for negative integers that we should be printing as
- * large positive ones *)
- if i < Int64.zero && (not (isSigned ik)) then
- if bytesSizeOfInt ik <> 8 then
- (* I am convinced that we shall never store smaller than 64-bits
- * integers in negative form. -- Gabriel *)
- E.s (E.bug "unexpected negative unsigned integer (please report this bug)")
- else
- text (prefix ^ "0x" ^ Int64.format "%x" i ^ suffix)
- else (
- if (i = mostNeg32BitInt) then
- (* sm: quirk here: if you print -2147483648 then this is two tokens *)
- (* in C, and the second one is too large to represent in a signed *)
- (* int.. so we do what's done in limits.h, and print (-2147483467-1); *)
- (* in gcc this avoids a warning, but it might avoid a real problem *)
- (* on another compiler or a 64-bit architecture *)
- text (prefix ^ "(-0x7FFFFFFF-1)")
- else if (i = mostNeg64BitInt) then
- (* The same is true of the largest 64-bit negative. *)
- text (prefix ^ "(-0x7FFFFFFFFFFFFFFF-1)")
- else
- text (prefix ^ (Int64.to_string i ^ suffix))
- )
- | CStr(s) -> text ("\"" ^ escape_string s ^ "\"")
- | CWStr(s) ->
- (* text ("L\"" ^ escape_string s ^ "\"") *)
- (List.fold_left (fun acc elt ->
- acc ++
- if (elt >= Int64.zero &&
- elt <= (Int64.of_int 255)) then
- text (escape_char (Char.chr (Int64.to_int elt)))
- else
- ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++
- (text "\""))
- ) (text "L\"") s ) ++ text "\""
- (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" --
- * the former has 7 wide characters and the later has 3. *)
- | CChr(c) -> text ("'" ^ escape_char c ^ "'")
- | CReal(_, _, Some s) -> text s
- | CReal(f, fsize, None) ->
- text (string_of_float f) ++
- (match fsize with
- FFloat -> chr 'f'
- | FDouble -> nil
- | FLongDouble -> chr 'L')
- | CEnum(_, s, ei) -> text s
- (* Parentheses/precedence level. An expression "a op b" is printed
- * parenthesized if its parentheses level is >= that that of its context.
- * Identifiers have the lowest level and weakly binding operators (e.g. |)
- * have the largest level. The correctness criterion is that a smaller level
- * MUST correspond to a stronger precedence! *)
- let derefStarLevel = 20
- let indexLevel = 20
- let arrowLevel = 20
- let addrOfLevel = 30
- let additiveLevel = 60
- let comparativeLevel = 70
- let bitwiseLevel = 75
- let questionLevel = 100
- let getParenthLevel (e: exp) =
- match e with
- | Question _ -> questionLevel
- | BinOp((LAnd | LOr), _,_,_) -> 80
- (* Bit operations. *)
- | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *)
- (* Comparisons *)
- | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) ->
- comparativeLevel (* 70 *)
- (* Additive. Shifts can have higher
- * level than + or - but I want
- * parentheses around them *)
- | BinOp((MinusA|MinusPP|MinusPI|PlusA|
- PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_)
- -> additiveLevel (* 60 *)
- (* Multiplicative *)
- | BinOp((Div|Mod|Mult),_,_,_) -> 40
- (* Unary *)
- | CastE(_,_) -> 30
- | AddrOf(_) -> 30
- | AddrOfLabel(_) -> 30
- | StartOf(_) -> 30
- | UnOp((Neg|BNot|LNot),_,_) -> 30
- (* Lvals *)
- | Lval(Mem _ , _) -> derefStarLevel (* 20 *)
- | Lval(Var _, (Field _|Index _)) -> indexLevel (* 20 *)
- | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20
- | AlignOf _ | AlignOfE _ -> 20
- | Lval(Var _, NoOffset) -> 0 (* Plain variables *)
- | Const _ -> 0 (* Constants *)
- let getParenthLevelAttrParam (a: attrparam) =
- (* Create an expression of the same shape, and use {!getParenthLevel} *)
- match a with
- AInt _ | AStr _ | ACons _ -> 0
- | ASizeOf _ | ASizeOfE _ | ASizeOfS _ -> 20
- | AAlignOf _ | AAlignOfE _ | AAlignOfS _ -> 20
- | AUnOp (uo, _) -> getParenthLevel (UnOp(uo, zero, intType))
- | ABinOp (bo, _, _) -> getParenthLevel (BinOp(bo, zero, zero, intType))
- | AAddrOf _ -> 30
- | ADot _ | AIndex _ | AStar _ -> 20
- | AQuestion _ -> questionLevel
- (* Separate out the storage-modifier name attributes *)
- let separateStorageModifiers (al: attribute list) =
- let isstoragemod (Attr(an, _): attribute) : bool =
- try
- match H.find attributeHash an with
- AttrName issm -> issm
- | _ -> false
- with Not_found -> false
- in
- let stom, rest = List.partition isstoragemod al in
- if not !msvcMode then
- stom, rest
- else
- (* Put back the declspec. Put it without the leading __ since these will
- * be added later *)
- let stom' =
- Util.list_map (fun (Attr(an, args)) ->
- Attr("declspec", [ACons(an, args)])) stom in
- stom', rest
- let isIntegralType t =
- match unrollType t with
- (TInt _ | TEnum _) -> true
- | _ -> false
- let isArithmeticType t =
- match unrollType t with
- (TInt _ | TEnum _ | TFloat _) -> true
- | _ -> false
-
- let isPointerType t =
- match unrollType t with
- TPtr _ -> true
- | _ -> false
- let isScalarType t =
- isArithmeticType t || isPointerType t
- let isFunctionType t =
- match unrollType t with
- TFun _ -> true
- | _ -> false
- (**** Compute the type of an expression ****)
- let rec typeOf (e: exp) : typ =
- match e with
- | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
- (* Character constants have type int. ISO/IEC 9899:1999 (E),
- * section 6.4.4.4 [Character constants], paragraph 10, if you
- * don't believe me. *)
- | Const(CChr _) -> intType
- (* The type of a string is a pointer to characters ! The only case when
- * you would want it to be an array is as an argument to sizeof, but we
- * have SizeOfStr for that *)
- | Const(CStr s) -> !stringLiteralType
- | Const(CWStr s) -> TPtr(!wcharType,[])
- | Const(CReal (_, fk, _)) -> TFloat(fk, [])
- | Const(CEnum(tag, _, ei)) -> typeOf tag
- | Lval(lv) -> typeOfLval lv
- | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf
- | AlignOf _ | AlignOfE _ -> !typeOfSizeOf
- | UnOp (_, _, t)
- | BinOp (_, _, _, t)
- | Question (_, _, _, t)
- | CastE (t, _) -> t
- | AddrOf (lv) -> TPtr(typeOfLval lv, [])
- | AddrOfLabel (lv) -> voidPtrType
- | StartOf (lv) -> begin
- match unrollType (typeOfLval lv) with
- TArray (t,_, a) -> TPtr(t, a)
- | _ -> E.s (E.bug "typeOf: StartOf on a non-array")
- end
- and typeOfInit (i: init) : typ =
- match i with
- SingleInit e -> typeOf e
- | CompoundInit (t, _) -> t
- and typeOfLval = function
- Var vi, off -> typeOffset vi.vtype off
- | Mem addr, off -> begin
- match unrollType (typeOf addr) with
- TPtr (t, _) -> typeOffset t off
- | _ -> E.s (bug "typeOfLval: Mem on a non-pointer (%a)" !pd_exp addr)
- end
- and typeOffset basetyp =
- let blendAttributes baseAttrs =
- let (_, _, contageous) =
- partitionAttributes ~default:(AttrName false) baseAttrs in
- typeAddAttributes contageous
- in
- function
- NoOffset -> basetyp
- | Index (_, o) -> begin
- match unrollType basetyp with
- TArray (t, _, baseAttrs) ->
- let elementType = typeOffset t o in
- blendAttributes baseAttrs elementType
- | t -> E.s (E.bug "typeOffset: Index on a non-array")
- end
- | Field (fi, o) ->
- match unrollType basetyp with
- TComp (_, baseAttrs) ->
- let fieldType = typeOffset fi.ftype o in
- blendAttributes baseAttrs fieldType
- | _ -> E.s (bug "typeOffset: Field on a non-compound")
- (**
- **
- ** MACHINE DEPENDENT PART
- **
- **)
- exception SizeOfError of string * typ
- let unsignedVersionOf (ik:ikind): ikind =
- match ik with
- | ISChar | IChar -> IUChar
- | IShort -> IUShort
- | IInt -> IUInt
- | ILong -> IULong
- | ILongLong -> IULongLong
- | _ -> ik
- let signedVersionOf (ik:ikind): ikind =
- match ik with
- | IUChar | IChar -> ISChar
- | IUShort -> IShort
- | IUInt -> IInt
- | IULong -> ILong
- | IULongLong -> ILongLong
- | _ -> ik
- (* Return the integer conversion rank of an integer kind *)
- let intRank (ik:ikind) : int =
- match ik with
- | IBool -> 0
- | IChar | ISChar | IUChar -> 1
- | IShort | IUShort -> 2
- | IInt | IUInt -> 3
- | ILong | IULong -> 4
- | ILongLong | IULongLong -> 5
- (* Return the common integer kind of the two integer arguments, as
- defined in ISO C 6.3.1.8 ("Usual arithmetic conversions") *)
- let commonIntKind (ik1:ikind) (ik2:ikind) : ikind =
- let r1 = intRank ik1 in
- let r2 = intRank ik2 in
- if (isSigned ik1) = (isSigned ik2) then begin
- (* Both signed or both unsigned. *)
- if r1 > r2 then ik1 else ik2
- end
- else begin
- let signedKind, unsignedKind, signedRank, unsignedRank =
- if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1
- in
- (* The rules for signed + unsigned get hairy.
- (unsigned short + long) is converted to signed long,
- but (unsigned int + long) is converted to unsigned long.*)
- if unsignedRank >= signedRank then unsignedKind
- else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then
- signedKind
- else
- unsignedVersionOf signedKind
- end
- let intKindForSize (s:int) (unsigned:bool) : ikind =
- if unsigned then
- (* Test the most common sizes first *)
- if s = 1 then IUChar
- else if s = !M.theMachine.M.sizeof_int then IUInt
- else if s = !M.theMachine.M.sizeof_long then IULong
- else if s = !M.theMachine.M.sizeof_short then IUShort
- else if s = !M.theMachine.M.sizeof_longlong then IULongLong
- else raise Not_found
- else
- (* Test the most common sizes first *)
- if s = 1 then ISChar
- else if s = !M.theMachine.M.sizeof_int then IInt
- else if s = !M.theMachine.M.sizeof_long then ILong
- else if s = !M.theMachine.M.sizeof_short then IShort
- else if s = !M.theMachine.M.sizeof_longlong then ILongLong
- else raise Not_found
- let floatKindForSize (s:int) =
- if s = !M.theMachine.M.sizeof_double then FDouble
- else if s = !M.theMachine.M.sizeof_float then FFloat
- else if s = !M.theMachine.M.sizeof_longdouble then FLongDouble
- else raise Not_found
- (* Represents an integer as for a given kind. Returns a flag saying
- whether any "interesting" bits were lost during truncation. By
- "interesting", we mean that the lost bits were not all-0 or all-1. *)
- let truncateCilint (k: ikind) (i: cilint) : cilint * truncation =
- (* Truncations to _Bool are special: they behave like "!= 0"
- ISO C99 6.3.1.2 *)
- if k = IBool then
- if is_zero_cilint i then
- zero_cilint, NoTruncation
- else
- one_cilint, NoTruncation
- else
- let nrBits = 8 * (bytesSizeOfInt k) in
- if isSigned k then
- truncate_signed_cilint i nrBits
- else
- truncate_unsigned_cilint i nrBits
- let mkCilint (ik:ikind) (i:int64) : cilint =
- fst (truncateCilint ik (cilint_of_int64 i))
- (* Construct an integer constant with possible truncation *)
- let kintegerCilint (k: ikind) (i: cilint) : exp =
- let i', truncated = truncateCilint k i in
- if truncated = BitTruncation && !warnTruncate then
- ignore (warnOpt "Truncating integer %s to %s"
- (string_of_cilint i) (string_of_cilint i'));
- Const (CInt64(int64_of_cilint i', k, None))
- (* Construct an integer constant with possible truncation *)
- let kinteger64 (k: ikind) (i: int64) : exp =
- kintegerCilint k (cilint_of_int64 i)
- (* Construct an integer of a given kind. *)
- let kinteger (k: ikind) (i: int) =
- kintegerCilint k (cilint_of_int i)
- (** Construct an integer of kind IInt. On targets where C's 'int' is 16-bits,
- the integer may get truncated. *)
- let integer (i: int) = kinteger IInt i
-
- let one = integer 1
- let mone = integer (-1)
-
- (* True if the integer fits within the kind's range *)
- let fitsInInt (k: ikind) (i: cilint) : bool =
- let _, truncated = truncateCilint k i in
- truncated = NoTruncation
- (* Return the smallest kind that will hold the integer's value. The
- kind will be unsigned if the 2nd argument is true, signed
- otherwise. Note that if the value doesn't fit in any of the
- available types, you will get ILongLong (2nd argument false) or
- IULongLong (2nd argument true). *)
- let intKindForValue (i: cilint) (unsigned: bool) =
- if unsigned then
- if fitsInInt IUChar i then IUChar
- else if fitsInInt IUShort i then IUShort
- else if fitsInInt IUInt i then IUInt
- else if fitsInInt IULong i then IULong
- else IULongLong
- else
- if fitsInInt ISChar i then ISChar
- else if fitsInInt IShort i then IShort
- else if fitsInInt IInt i then IInt
- else if fitsInInt ILong i then ILong
- else ILongLong
- (** If the given expression is an integer constant or a CastE'd
- integer constant, return that constant's value as an ikint, int64 pair.
- Otherwise return None. *)
- let rec getInteger (e:exp) : cilint option =
- match e with
- | Const(CInt64 (n, ik, _)) -> Some (mkCilint ik n)
- | Const(CChr c) -> getInteger (Const (charConstToInt c))
- | Const(CEnum(v, _, _)) -> getInteger v
- | CastE(t, e) -> begin
- (* Handle any truncation due to cast. We optimistically ignore
- loss-of-precision due to floating-point casts. *)
- let mkInt ik n = Some (fst (truncateCilint ik n)) in
- match unrollType t, getInteger e with
- | TInt (ik, _), Some n -> mkInt ik n
- | TPtr _, Some n -> begin
- match !upointType with
- TInt (ik, _) -> mkInt ik n
- | _ -> raise (Failure "pointer size unknown")
- end
- | TEnum (ei, _), Some n -> mkInt ei.ekind n
- | TFloat _, v -> v
- | _, _ -> None
- end
- | _ -> None
- let isZero (e: exp) : bool =
- match getInteger e with
- | Some n -> is_zero_cilint n
- | _ -> false
- type offsetAcc =
- { oaFirstFree: int; (* The first free bit *)
- oaLastFieldStart: int; (* Where the previous field started *)
- oaLastFieldWidth: int; (* The width of the previous field. Might not
- * be same as FirstFree - FieldStart because
- * of internal padding *)
- oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
- * were packed bitfields,
- * the bit where packing
- * has started, the ikind
- * of the bitfield and the
- * width of the ikind *)
- }
- (* Hack to prevent infinite recursion in alignments *)
- let ignoreAlignmentAttrs = ref false
-
- (* Get the minimum aligment in bytes for a given type *)
- let rec alignOf_int t =
- let alignOfType () =
- match t with
- | TInt((IChar|ISChar|IUChar), _) -> 1
- | TInt(IBool, _) -> !M.theMachine.M.alignof_bool
- | TInt((IShort|IUShort), _) -> !M.theMachine.M.alignof_short
- | TInt((IInt|IUInt), _) -> !M.theMachine.M.alignof_int
- | TInt((ILong|IULong), _) -> !M.theMachine.M.alignof_long
- | TInt((ILongLong|IULongLong), _) -> !M.theMachine.M.alignof_longlong
- | TEnum(ei, _) -> alignOf_int (TInt(ei.ekind, []))
- | TFloat(FFloat, _) -> !M.theMachine.M.alignof_float
- | TFloat(FDouble, _) -> !M.theMachine.M.alignof_double
- | TFloat(FLongDouble, _) -> !M.theMachine.M.alignof_longdouble
- | TNamed (t, _) -> alignOf_int t.ttype
- | TArray (t, _, _) -> alignOf_int t
- | TPtr _ | TBuiltin_va_list _ -> !M.theMachine.M.alignof_ptr
-
- (* For composite types get the maximum alignment of any field inside *)
- | TComp (c, _) ->
- (* On GCC the zero-width fields do not contribute to the alignment.
- * On MSVC only those zero-width that _do_ appear after other
- * bitfields contribute to the alignment. So we drop those that
- * do not occur after othe bitfields *)
- let rec dropZeros (afterbitfield: bool) = function
- | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
- dropZeros afterbitfield rest
- | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
- | [] -> []
- in
- let fields = dropZeros false c.cfields in
- List.fold_left
- (fun sofar f ->
- (* Bitfields with zero width do not contribute to the alignment in
- * GCC *)
- if not !msvcMode && f.fbitfield = Some 0 then sofar else
- max sofar (alignOfField f)) 1 fields
- (* These are some error cases *)
- | TFun _ when not !msvcMode -> !M.theMachine.M.alignof_fun
-
- | TFun _ as t -> raise (SizeOfError ("function", t))
- | TVoid _ as t -> raise (SizeOfError ("void", t))
- in
- match filterAttributes "aligned" (typeAttrs t) with
- [] ->
- (* no __aligned__ attribute, so get the default alignment *)
- alignOfType ()
- | _ when !ignoreAlignmentAttrs ->
- ignore (warn "ignoring recursive align attributes on %a"
- (!pd_type) t);
- alignOfType ()
- | (Attr(_, [a]) as at)::rest -> begin
- if rest <> [] then
- ignore (warn "ignoring duplicate align attributes on %a"
- (!pd_type) t);
- match intOfAttrparam a with
- Some n -> n
- | None ->
- ignore (warn "alignment attribute \"%a\" not understood on %a"
- (!pd_attr) at (!pd_type) t);
- alignOfType ()
- end
- | Attr(_, [])::rest ->
- (* aligned with no arg means a power of two at least as large as
- any alignment on the system.*)
- if rest <> [] then
- ignore(warn "ignoring duplicate align attributes on %a"
- (!pd_type) t);
- !M.theMachine.M.alignof_aligned
- | at::_ ->
- ignore (warn "alignment attribute \"%a\" not understood on %a"
- (!pd_attr) at (!pd_type) t);
- alignOfType ()
- (* alignment of a possibly-packed struct field. *)
- and alignOfField (fi: fieldinfo) =
- let fieldIsPacked = hasAttribute "packed" fi.fattr
- || hasAttribute "packed" fi.fcomp.cattr in
- if fieldIsPacked then 1
- else alignOf_int fi.ftype
-
- and intOfAttrparam (a:attrparam) : int option =
- let rec doit a : int =
- match a with
- AInt(n) -> n
- | ABinOp(Shiftlt, a1, a2) -> (doit a1) lsl (doit a2)
- | ABinOp(Div, a1, a2) -> (doit a1) / (doit a2)
- | ASizeOf(t) ->
- let bs = bitsSizeOf t in
- bs / 8
- | AAlignOf(t) ->
- alignOf_int t
- | _ -> raise (SizeOfError ("", voidType))
- in
- (* Use ignoreAlignmentAttrs here to prevent stack overflow if a buggy
- program does something like
- struct s {...} __attribute__((aligned(sizeof(struct s))))
- This is too conservative, but it's often enough.
- *)
- assert (not !ignoreAlignmentAttrs);
- ignoreAlignmentAttrs := true;
- try
- let n = doit a in
- ignoreAlignmentAttrs := false;
- Some n
- with SizeOfError _ -> (* Can't compile *)
- ignoreAlignmentAttrs := false;
- None
- (* GCC version *)
- (* Does not use the sofar.oaPrevBitPack *)
- and offsetOfFieldAcc_GCC
- (fi: fieldinfo)
- (sofar: offsetAcc) : offsetAcc =
- (* field type *)
- let ftype = unrollType fi.ftype in
- let ftypeAlign = 8 * alignOfField fi in
- let ftypeBits = bitsSizeOf ftype in
- match ftype, fi.fbitfield with
- (* A width of 0 means that we must end the current packing. It seems that
- * GCC pads only up to the alignment boundary for the type of this field.
- * *)
- | _, Some 0 ->
- let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = firstFree;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None }
- (* A bitfield cannot span more alignment boundaries of its type than the
- * type itself *)
- | _, Some wdthis
- when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
- - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
- let start = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = start + wdthis;
- oaLastFieldStart = start;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = None }
-
- (* Try a simple method. Just put the field down *)
- | _, Some wdthis ->
- { oaFirstFree = sofar.oaFirstFree + wdthis;
- oaLastFieldStart = sofar.oaFirstFree;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = None
- }
- (* Non-bitfield *)
- | _, None ->
- (* Align this field *)
- let newStart = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = newStart + ftypeBits;
- oaLastFieldStart = newStart;
- oaLastFieldWidth = ftypeBits;
- oaPrevBitPack = None;
- }
- (* MSVC version *)
- and offsetOfFieldAcc_MSVC (fi: fieldinfo)
- (sofar: offsetAcc) : offsetAcc =
- (* field type *)
- let ftype = unrollType fi.ftype in
- let ftypeAlign = 8 * alignOf_int ftype in
- let ftypeBits = bitsSizeOf ftype in
- (*
- ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n"
- fi.fname fi.fcomp.cname
- d_type ftype
- insert
- (match fi.fbitfield with
- None -> nil
- | Some wdthis -> dprintf ":%d" wdthis)
- sofar.oaFirstFree
- insert
- (match sofar.oaPrevBitPack with
- None -> text "None"
- | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)"
- prevpack wdpack));
- *)
- match ftype, fi.fbitfield, sofar.oaPrevBitPack with
- (* Ignore zero-width bitfields that come after non-bitfields *)
- | TInt (ikthis, _), Some 0, None ->
- let firstFree = sofar.oaFirstFree in
- { oaFirstFree = firstFree;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None }
- (* If we are in a bitpack and we see a bitfield for a type with the
- * different width than the pack, then we finish the pack and retry *)
- | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
- let firstFree =
- if sofar.oaFirstFree = packstart then packstart else
- packstart + wdpack
- in
- offsetOfFieldAcc_MSVC fi
- { oaFirstFree = addTrailing firstFree ftypeAlign;
- oaLastFieldStart = sofar.oaLastFieldStart;
- oaLastFieldWidth = sofar.oaLastFieldWidth;
- oaPrevBitPack = None }
- (* A width of 0 means that we must end the current packing. *)
- | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
- let firstFree =
- if sofar.oaFirstFree = packstart then packstart else
- packstart + wdpack
- in
- let firstFree = addTrailing firstFree ftypeAlign in
- { oaFirstFree = firstFree;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = 0;
- oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) }
- (* Check for a bitfield that fits in the current pack after some other
- * bitfields *)
- | TInt(ikthis, _), Some wdthis, Some (packstart, ikprev, wdpack)
- when packstart + wdpack >= sofar.oaFirstFree + wdthis ->
- { oaFirstFree = sofar.oaFirstFree + wdthis;
- oaLastFieldStart = sofar.oaFirstFree;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = sofar.oaPrevBitPack
- }
- | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
- * restart. *)
- let firstFree =
- if sofar.oaFirstFree = packstart then packstart else
- packstart + wdpack
- in
- offsetOfFieldAcc_MSVC fi
- { oaFirstFree = addTrailing firstFree ftypeAlign;
- oaLastFieldStart = sofar.oaLastFieldStart;
- oaLastFieldWidth = sofar.oaLastFieldWidth;
- oaPrevBitPack = None }
- (* No active bitfield pack. But we are seeing a bitfield. *)
- | TInt(ikthis, _), Some wdthis, None ->
- let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = firstFree + wdthis;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = wdthis;
- oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
- (* No active bitfield pack. Non-bitfield *)
- | _, None, None ->
- (* Align this field *)
- let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
- { oaFirstFree = firstFree + ftypeBits;
- oaLastFieldStart = firstFree;
- oaLastFieldWidth = ftypeBits;
- oaPrevBitPack = None;
- }
- | _, Some _, None -> E.s (E.bug "offsetAcc")
- and offsetOfFieldAcc ~(fi: fieldinfo)
- ~(sofar: offsetAcc) : offsetAcc =
- if !msvcMode then offsetOfFieldAcc_MSVC fi sofar
- else offsetOfFieldAcc_GCC fi sofar
- (* The size of a type, in bits. If a struct or array, then trailing padding is
- * added *)
- and bitsSizeOf t =
- if not !initCIL_called then
- E.s (E.error "You did not call Cil.initCIL before using the CIL library");
- match t with
- | TInt (ik,_) -> 8 * (bytesSizeOfInt ik)
- | TFloat(FDouble, _) -> 8 * !M.theMachine.M.sizeof_double
- | TFloat(FLongDouble, _) -> 8 * !M.theMachine.M.sizeof_longdouble
- | TFloat _ -> 8 * !M.theMachine.M.sizeof_float
- | TEnum (ei, _) -> bitsSizeOf (TInt(ei.ekind, []))
- | TPtr _ -> 8 * !M.theMachine.M.sizeof_ptr
- | TBuiltin_va_list _ -> 8 * !M.theMachine.M.sizeof_ptr
- | TNamed (t, _) -> bitsSizeOf t.ttype
- | TComp (comp, _) when comp.cfields == [] -> begin
- (* Empty structs are allowed in msvc mode *)
- if not comp.cdefined && not !msvcMode then
- raise (SizeOfError ("abstract type", t)) (*abstract type*)
- else
- 0
- end
- | TComp (comp, _) when comp.cstruct -> (* Struct *)
- (* Go and get the last offset *)
- let startAcc =
- { oaFirstFree = 0;
- oaLastFieldStart = 0;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None;
- } in
- let lastoff =
- List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc)
- startAcc comp.cfields
- in
- if !msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then
- (* On MSVC if we have just a zero-width bitfields then the length
- * is 32 and is not padded *)
- 32
- else begin
- (* Drop e.g. the align attribute from t. For this purpose,
- consider only the attributes on comp itself.*)
- let structAlign = 8 * alignOf_int
- (TComp (comp, [])) in
- addTrailing lastoff.oaFirstFree structAlign
- end
-
- | TComp (comp, _) -> (* when not comp.cstruct *)
- (* Get the maximum of all fields *)
- let startAcc =
- { oaFirstFree = 0;
- oaLastFieldStart = 0;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None;
- } in
- let max =
- List.fold_left (fun acc fi ->
- let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in
- if lastoff.oaFirstFree > acc then
- lastoff.oaFirstFree else acc) 0 comp.cfields in
- (* Add trailing by simulating adding an extra field *)
- addTrailing max (8 * alignOf_int t)
- | TArray(bt, Some len, _) -> begin
- match constFold true len with
- Const(CInt64(l,lk,_)) ->
- let sz = mul_cilint (mkCilint lk l) (cilint_of_int (bitsSizeOf bt)) in
- (* Check for overflow.
- There are other places in these cil.ml that overflow can occur,
- but this multiplication is the most likely to be a problem. *)
- if not (is_int_cilint sz) then
- raise (SizeOfError ("Array is so long that its size can't be "
- ^"represented with an OCaml int.", t))
- else
- addTrailing (int_of_cilint sz) (8 * alignOf_int t)
- | _ -> raise (SizeOfError ("array non-constant length", t))
- end
- | TVoid _ -> 8 * !M.theMachine.M.sizeof_void
- | TFun _ when not !msvcMode -> (* On GCC the size of a function is defined *)
- 8 * !M.theMachine.M.sizeof_fun
- | TArray (_, None, _) -> (* it seems that on GCC the size of such an
- * array is 0 *)
- 0
- | TFun _ -> raise (SizeOfError ("function", t))
- and addTrailing nrbits roundto =
- (nrbits + roundto - 1) land (lnot (roundto - 1))
- and sizeOf t =
- try
- integer ((bitsSizeOf t) lsr 3)
- with SizeOfError _ -> SizeOf(t)
-
- and bitsOffset (baset: typ) (off: offset) : int * int =
- let rec loopOff (baset: typ) (width: int) (start: int) = function
- NoOffset -> start, width
- | Index(e, off) -> begin
- let ei =
- match getInteger e with
- Some i -> cilint_to_int i
- | None -> raise (SizeOfError ("index not constant", baset))
- in
- let bt =
- match unrollType baset with
- TArray(bt, _, _) -> bt
- | _ -> E.s (E.bug "bitsOffset: Index on a non-array")
- in
- let bitsbt = bitsSizeOf bt in
- loopOff bt bitsbt (start + ei * bitsbt) off
- end
- | Field(f, off) when not f.fcomp.cstruct ->
- (* All union fields start at offset 0 *)
- loopOff f.ftype (bitsSizeOf f.ftype) start off
- | Field(f, off) ->
- (* Construct a list of fields preceeding and including this one *)
- let prevflds =
- let rec loop = function
- [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n"
- f.fname f.fcomp.cname)
- | fi' :: _ when fi' == f -> [fi']
- | fi' :: rest -> fi' :: loop rest
- in
- loop f.fcomp.cfields
- in
- let lastoff =
- List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc)
- { oaFirstFree = 0; (* Start at 0 because each struct is done
- * separately *)
- oaLastFieldStart = 0;
- oaLastFieldWidth = 0;
- oaPrevBitPack = None } prevflds
- in
- (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n"
- f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *)
- loopOff f.ftype lastoff.oaLastFieldWidth
- (start + lastoff.oaLastFieldStart) off
- in
- loopOff baset (bitsSizeOf baset) 0 off
-
- (** Do constant folding on an expression. If the first argument is true then
- will also compute compiler-dependent expressions such as sizeof.
- See also {!Cil.constFoldVisitor}, which will run constFold on all
- expressions in a given AST node.*)
- and constFold (machdep: bool) (e: exp) : exp =
- match e with
- BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres
- | UnOp(unop, e1, tres) -> begin
- try
- let tk =
- match unrollType tres with
- TInt(ik, _) -> ik
- | TEnum (ei, _) -> ei.ekind
- | _ -> raise Not_found (* probably a float *)
- in
- match constFold machdep e1 with
- Const(CInt64(i,ik,_)) -> begin
- let ic = mkCilint ik i in
- match unop with
- Neg -> kintegerCilint tk (neg_cilint ic)
- | BNot -> kintegerCilint tk (lognot_cilint ic)
- | LNot -> if is_zero_cilint ic then one else zero
- end
- | e1c -> UnOp(unop, e1c, tres)
- with Not_found -> e
- end
- (* Characters are integers *)
- | Const(CChr c) -> Const(charConstToInt c)
- | Const(CEnum (v, _, _)) -> constFold machdep v
- | SizeOf t when machdep -> begin
- try
- let bs = bitsSizeOf t in
- kinteger !kindOfSizeOf (bs / 8)
- with SizeOfError _ -> e
- end
- | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e))
- | SizeOfStr s when machdep -> kinteger !kindOfSizeOf (1 + String.length s)
- | AlignOf t when machdep -> kinteger !kindOfSizeOf (alignOf_int t)
- | AlignOfE e when machdep -> begin
- (* The alignment of an expression is not always the alignment of its
- * type. I know that for strings this is not true *)
- match e with
- Const (CStr _) when not !msvcMode ->
- kinteger !kindOfSizeOf !M.theMachine.M.alignof_str
- (* For an array, it is the alignment of the array ! *)
- | _ -> constFold machdep (AlignOf (typeOf e))
- end
- | CastE(it,
- AddrOf (Mem (CastE(TPtr(bt, _), z)), off))
- when machdep && isZero z -> begin
- try
- let start, width = bitsOffset bt off in
- if start mod 8 <> 0 then
- E.s (error "Using offset of bitfield");
- constFold machdep (CastE(it, (kinteger !kindOfSizeOf (start / 8))))
- with SizeOfError _ -> e
- end
-
- | CastE (t, e) -> begin
- match constFold machdep e, unrollType t with
- (* Might truncate silently *)
- | Const(CInt64(i,k,_)), TInt(nk,a)
- (* It's okay to drop a cast to const.
- If the cast has any other attributes, leave the cast alone. *)
- when (dropAttributes ["const"] a) = [] ->
- let i', _ = truncateCilint nk (mkCilint k i) in
- Const(CInt64(int64_of_cilint i', nk, None))
- | e', _ -> CastE (t, e')
- end
- | Lval lv -> Lval (constFoldLval machdep lv)
- | AddrOf lv -> AddrOf (constFoldLval machdep lv)
- | StartOf lv -> StartOf (constFoldLval machdep lv)
- | _ -> e
- and constFoldLval machdep (host,offset) =
- let newhost =
- match host with
- | Mem e -> Mem (constFold machdep e)
- | Var _ -> host
- in
- let rec constFoldOffset machdep = function
- | NoOffset -> NoOffset
- | Field (fi,offset) -> Field (fi, constFoldOffset machdep offset)
- | Index (exp,offset) -> Index (constFold machdep exp,
- constFoldOffset machdep offset)
- in
- (newhost, constFoldOffset machdep offset)
- and constFoldBinOp (machdep: bool) bop e1 e2 tres =
- let e1' = constFold machdep e1 in
- let e2' = constFold machdep e2 in
- if isIntegralType tres then begin
- let newe =
- let tk =
- match unrollType tres with
- TInt(ik, _) -> ik
- | TEnum (ei, _) -> ei.ekind
- | _ -> E.s (bug "constFoldBinOp")
- in
- let collapse0 () = kinteger tk 0 in
- let collapse e = e (*mkCast e tres*) in
- let shiftInBounds i2 =
- (* We only try to fold shifts if the second arg is positive and
- less than the size of the type of the first argument.
- Otherwise, the semantics are processor-dependent, so let the
- compiler sort it out. *)
- if machdep then
- try
- compare_cilint i2 zero_cilint >= 0 &&
- compare_cilint i2 (cilint_of_int (bitsSizeOf (typeOf e1'))) < 0
- with SizeOfError _ -> false
- else false
- in
- (* Assume that the necessary promotions have been done *)
- match bop, getInteger e1', getInteger e2' with
- | PlusA, Some i1, Some i2 -> kintegerCilint tk (add_cilint i1 i2)
- | PlusA, Some z, _ when is_zero_cilint z -> collapse e2'
- | PlusA, _, Some z when is_zero_cilint z -> collapse e1'
- | MinusA, Some i1, Some i2 -> kintegerCilint tk (sub_cilint i1 i2)
- | MinusA, _, Some z when is_zero_cilint z -> collapse e1'
- | Mult, Some i1, Some i2 -> kintegerCilint tk (mul_cilint i1 i2)
- | Mult, Some z, _ when is_zero_cilint z -> collapse0 ()
- | Mult, _, Some z when is_zero_cilint z -> collapse0 ()
- | Mult, Some o, _ when compare_cilint o one_cilint = 0 -> collapse e2'
- | Mult, _, Some o when compare_cilint o one_cilint = 0 -> collapse e1'
- | Div, Some i1, Some i2 -> begin
- try kintegerCilint tk (div0_cilint i1 i2)
- with Division_by_zero -> BinOp(bop, e1', e2', tres)
- end
- | Div, _, Some o when compare_cilint o one_cilint = 0 -> collapse e1'
- | Mod, Some i1, Some i2 -> begin
- try kintegerCilint tk (rem_cilint i1 i2)
- with Division_by_zero -> BinOp(bop, e1', e2', tres)
- end
- | Mod, _, Some o when compare_cilint o one_cilint = 0 -> collapse0 ()
- | BAnd, Some i1, Some i2 -> kintegerCilint tk (logand_cilint i1 i2)
- | BAnd, Some z, _ when is_zero_cilint z -> collapse0 ()
- | BAnd, _, Some z when is_zero_cilint z -> collapse0 ()
- | BOr, Some i1, Some i2 -> kintegerCilint tk (logor_cilint i1 i2)
- | BOr, Some z, _ when is_zero_cilint z -> collapse e2'
- | BOr, _, Some z when is_zero_cilint z -> collapse e1'
- | BXor, Some i1, Some i2 -> kintegerCilint tk (logxor_cilint i1 i2)
- | BXor, Some z, _ when is_zero_cilint z -> collapse e2'
- | BXor, _, Some z when is_zero_cilint z -> collapse e1'
- | Shiftlt, Some i1, Some i2 when shiftInBounds i2 ->
- kintegerCilint tk (shift_left_cilint i1 (int_of_cilint i2))
- | Shiftlt, Some z, _ when is_zero_cilint z -> collapse0 ()
- | Shiftlt, _, Some z when is_zero_cilint z -> collapse e1'
- | Shiftrt, Some i1, Some i2 when shiftInBounds i2 ->
- kintegerCilint tk (shift_right_cilint i1 (int_of_cilint i2))
- | Shiftrt, Some z, _ when is_zero_cilint z -> collapse0 ()
- | Shiftrt, _, Some z when is_zero_cilint z -> collapse e1'
- | Eq, Some i1, Some i2 -> if compare_cilint i1 i2 = 0 then one else zero
- | Ne, Some i1, Some i2 -> if compare_cilint i1 i2 <> 0 then one else zero
- | Le, Some i1, Some i2 -> if compare_cilint i1 i2 <= 0 then one else zero
- | Ge, Some i1, Some i2 -> if compare_cilint i1 i2 >= 0 then one else zero
- | Lt, Some i1, Some i2 -> if compare_cilint i1 i2 < 0 then one else zero
- | Gt, Some i1, Some i2 -> if compare_cilint i1 i2 > 0 then one else zero
- | LAnd, Some i1, _ -> if is_zero_cilint i1 then collapse0 () else collapse e2'
- | LAnd, _, Some i2 -> if is_zero_cilint i2 then collapse0 () else collapse e1'
- | LOr, Some i1, _ -> if is_zero_cilint i1 then collapse e2' else one
- | LOr, _, Some i2 -> if is_zero_cilint i2 then collapse e1' else one
- | _ -> BinOp(bop, e1', e2', tres)
- in
- if debugConstFold then
- ignore (E.log "Folded %a to %a\n"
- (!pd_exp) (BinOp(bop, e1', e2', tres)) (!pd_exp) newe);
- newe
- end else
- BinOp(bop, e1', e2', tres)
- let parseInt (str: string) : exp =
- let hasSuffix str =
- let l = String.length str in
- fun s ->
- let ls = String.length s in
- l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
- in
- let l = String.length str in
- (* See if it is octal or hex *)
- let octalhex = (l >= 1 && String.get str 0 = '0') in
- (* The length of the suffix and a list of possible kinds. See ISO
- * 6.4.4.1 *)
- let hasSuffix = hasSuffix str in
- let suffixlen, kinds =
- if hasSuffix "ULL" || hasSuffix "LLU" then
- 3, [IULongLong]
- else if hasSuffix "LL" then
- 2, if octalhex then [ILongLong; IULongLong] else [ILongLong]
- else if hasSuffix "UL" || hasSuffix "LU" then
- 2, [IULong; IULongLong]
- else if hasSuffix "L" then
- 1, if octalhex then [ILong; IULong; ILongLong; IULongLong]
- else [ILong; ILongLong]
- else if hasSuffix "U" then
- 1, [IUInt; IULong; IULongLong]
- else if (!msvcMode && hasSuffix "UI64") then
- 4, [IULongLong]
- else if (!msvcMode && hasSuffix "I64") then
- 3, [ILongLong]
- else
- 0, if octalhex then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
- else if not !c99Mode then [ IInt; ILong; IULong; ILongLong; IULongLong]
- else [IInt; ILong; ILongLong]
- in
- (* Convert to integer. To prevent overflow we do the arithmetic on
- * cilints. We work only with positive integers since the lexer
- * takes care of the sign *)
- let rec toInt (base: cilint) (acc: cilint) (idx: int) : cilint =
- let doAcc (what: int) =
- let acc' = add_cilint (mul_cilint base acc) (cilint_of_int what) in
- toInt base acc' (idx + 1)
- in
- if idx >= l - suffixlen then begin
- acc
- end else
- let ch = String.get str idx in
- if ch >= '0' && ch <= '9' then
- doAcc (Char.code ch - Char.code '0')
- else if ch >= 'a' && ch <= 'f' then
- doAcc (10 + Char.code ch - Char.code 'a')
- else if ch >= 'A' && ch <= 'F' then
- doAcc (10 + Char.code ch - Char.code 'A')
- else
- E.s (bug "Invalid integer constant: %s (char %c at idx=%d)"
- str ch idx)
- in
- let i =
- if octalhex then
- if l >= 2 &&
- (let c = String.get str 1 in c = 'x' || c = 'X') then
- toInt (cilint_of_int 16) zero_cilint 2
- else
- toInt (cilint_of_int 8) zero_cilint 1
- else
- toInt (cilint_of_int 10) zero_cilint 0
- in
- (* Construct an integer of the first kinds that fits. i must be
- * POSITIVE *)
- let res =
- let rec loop = function
- k::rest ->
- if fitsInInt k i then kintegerCilint k i
- else loop rest
- | [] -> E.s (E.unimp "Cannot represent the integer %s\n"
- (string_of_cilint i))
- in
- loop kinds
- in
- res
- (* with e -> begin *)
- (* ignore (E.log "int_of_string %s (%s)\n" str *)
- (* (Printexc.to_string e)); *)
- (* zero *)
- (* end *)
- let d_unop () u =
- match u with
- Neg -> text "-"
- | BNot -> text "~"
- | LNot -> text "!"
- let d_binop () b =
- match b with
- PlusA | PlusPI | IndexPI -> text "+"
- | MinusA | MinusPP | MinusPI -> text "-"
- | Mult -> text "*"
- | Div -> text "/"
- | Mod -> text "%"
- | Shiftlt -> text "<<"
- | Shiftrt -> text ">>"
- | Lt -> text "<"
- | Gt -> text ">"
- | Le -> text "<="
- | Ge -> text ">="
- | Eq -> text "=="
- | Ne -> text "!="
- | BAnd -> text "&"
- | BXor -> text "^"
- | BOr -> text "|"
- | LAnd -> text "&&"
- | LOr -> text "||"
- let invalidStmt = mkStmt (Instr [])
- (** Construct a hash with the builtins *)
- let builtinFunctions : (string, typ * typ list * bool) H.t =
- H.create 49
- (* Initialize the builtin functions after the machine has been initialized. *)
- let initGccBuiltins () : unit =
- if not !initCIL_called then
- E.s (bug "Call initCIL before initGccBuiltins");
- if H.length builtinFunctions <> 0 then
- E.s (bug "builtins already initialized.");
- let h = builtinFunctions in
- (* See if we have builtin_va_list *)
- let hasbva = !M.theMachine.M.__builtin_va_list in
- let ulongLongType = TInt(IULongLong, []) in
- let floatType = TFloat(FFloat, []) in
- let longDoubleType = TFloat (FLongDouble, []) in
- let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], []) in
- let sizeType = !typeOfSizeOf in
- let v4sfType = TFloat (FFloat,[Attr("__vector_size__", [AInt 16])]) in
- H.add h "__builtin___fprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
- H.add h "__builtin___memcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
- H.add h "__builtin___memmove_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
- H.add h "__builtin___mempcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
- H.add h "__builtin___memset_chk" (voidPtrType, [ voidPtrType; intType; sizeType; sizeType ], false);
- H.add h "__builtin___printf_chk" (intType, [ intType; charConstPtrType ], true);
- H.add h "__builtin___snprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType ], true);
- H.add h "__builtin___sprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType ], true);
- H.add h "__builtin___stpcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
- H.add h "__builtin___strcat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
- H.add h "__builtin___strcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
- H.add h "__builtin___strncat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
- H.add h "__builtin___strncpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
- H.add h "__builtin___vfprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ], false) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
- H.add h "__builtin___vprintf_chk" (intType, [ intType; charConstPtrType; TBuiltin_va_list [] ], false);
- H.add h "__builtin___vsnprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false);
- H.add h "__builtin___vsprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false);
- H.add h "__builtin_acos" (doubleType, [ doubleType ], false);
- H.add h "__builtin_acosf" (floatType, [ floatType ], false);
- H.add h "__builtin_acosl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_alloca" (voidPtrType, [ sizeType ], false);
-
- H.add h "__builtin_asin" (doubleType, [ doubleType ], false);
- H.add h "__builtin_asinf" (floatType, [ floatType ], false);
- H.add h "__builtin_asinl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_atan" (doubleType, [ doubleType ], false);
- H.add h "__builtin_atanf" (floatType, [ floatType ], false);
- H.add h "__builtin_atanl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_atan2" (doubleType, [ doubleType; doubleType ], false);
- H.add h "__builtin_atan2f" (floatType, [ floatType; floatType ], false);
- H.add h "__builtin_atan2l" (longDoubleType, [ longDoubleType;
- longDoubleType ], false);
- let addSwap sizeInBits =
- try
- assert (sizeInBits mod 8 = 0);
- let sizeInBytes = sizeInBits / 8 in
- let sizedIntType = TInt (intKindForSize sizeInBytes false, []) in
- let name = Printf.sprintf "__builtin_bswap%d" sizeInBits in
- H.add h name (sizedIntType, [ sizedIntType ], false)
- with Not_found ->
- ()
- in
- addSwap 16;
- addSwap 32;
- addSwap 64;
- H.add h "__builtin_ceil" (doubleType, [ doubleType ], false);
- H.add h "__builtin_ceilf" (floatType, [ floatType ], false);
- H.add h "__builtin_ceill" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_cos" (doubleType, [ doubleType ], false);
- H.add h "__builtin_cosf" (floatType, [ floatType ], false);
- H.add h "__builtin_cosl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_cosh" (doubleType, [ doubleType ], false);
- H.add h "__builtin_coshf" (floatType, [ floatType ], false);
- H.add h "__builtin_coshl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_clz" (intType, [ uintType ], false);
- H.add h "__builtin_clzl" (intType, [ ulongType ], false);
- H.add h "__builtin_clzll" (intType, [ ulongLongType ], false);
- H.add h "__builtin_constant_p" (intType, [ intType ], false);
- H.add h "__builtin_ctz" (intType, [ uintType ], false);
- H.add h "__builtin_ctzl" (intType, [ ulongType ], false);
- H.add h "__builtin_ctzll" (intType, [ ulongLongType ], false);
- H.add h "__builtin_exp" (doubleType, [ doubleType ], false);
- H.add h "__builtin_expf" (floatType, [ floatType ], false);
- H.add h "__builtin_expl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_expect" (longType, [ longType; longType ], false);
- H.add h "__builtin_trap" (voidType, [], false);
- H.add h "__builtin_unreachable" (voidType, [], false);
- H.add h "__builtin_fabs" (doubleType, [ doubleType ], false);
- H.add h "__builtin_fabsf" (floatType, [ floatType ], false);
- H.add h "__builtin_fabsl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_ffs" (intType, [ uintType ], false);
- H.add h "__builtin_ffsl" (intType, [ ulongType ], false);
- H.add h "__builtin_ffsll" (intType, [ ulongLongType ], false);
- H.add h "__builtin_frame_address" (voidPtrType, [ uintType ], false);
- H.add h "__builtin_floor" (doubleType, [ doubleType ], false);
- H.add h "__builtin_floorf" (floatType, [ floatType ], false);
- H.add h "__builtin_floorl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_huge_val" (doubleType, [], false);
- H.add h "__builtin_huge_valf" (floatType, [], false);
- H.add h "__builtin_huge_vall" (longDoubleType, [], false);
- H.add h "__builtin_inf" (doubleType, [], false);
- H.add h "__builtin_inff" (floatType, [], false);
- H.add h "__builtin_infl" (longDoubleType, [], false);
- H.add h "__builtin_memcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false);
- H.add h "__builtin_mempcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false);
- H.add h "__builtin_memset" (voidPtrType,
- [ voidPtrType; intType; intType ], false);
- H.add h "__builtin_bcopy" (voidType, [ voidConstPtrType; voidPtrType; sizeType ], false);
- H.add h "__builtin_bzero" (voidType,
- [ voidPtrType; sizeType ], false);
- H.add h "__builtin_fmod" (doubleType, [ doubleType ], false);
- H.add h "__builtin_fmodf" (floatType, [ floatType ], false);
- H.add h "__builtin_fmodl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_frexp" (doubleType, [ doubleType; intPtrType ], false);
- H.add h "__builtin_frexpf" (floatType, [ floatType; intPtrType ], false);
- H.add h "__builtin_frexpl" (longDoubleType, [ longDoubleType;
- intPtrType ], false);
- H.add h "__builtin_ldexp" (doubleType, [ doubleType; intType ], false);
- H.add h "__builtin_ldexpf" (floatType, [ floatType; intType ], false);
- H.add h "__builtin_ldexpl" (longDoubleType, [ longDoubleType;
- intType ], false);
- H.add h "__builtin_log" (doubleType, [ doubleType ], false);
- H.add h "__builtin_logf" (floatType, [ floatType ], false);
- H.add h "__builtin_logl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_log10" (doubleType, [ doubleType ], false);
- H.add h "__builtin_log10f" (floatType, [ floatType ], false);
- H.add h "__builtin_log10l" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_modff" (floatType, [ floatType;
- TPtr(floatType,[]) ], false);
- H.add h "__builtin_modfl" (longDoubleType, [ longDoubleType;
- TPtr(longDoubleType, []) ],
- false);
- H.add h "__builtin_nan" (doubleType, [ charConstPtrType ], false);
- H.add h "__builtin_nanf" (floatType, [ charConstPtrType ], false);
- H.add h "__builtin_nanl" (longDoubleType, [ charConstPtrType ], false);
- H.add h "__builtin_nans" (doubleType, [ charConstPtrType ], false);
- H.add h "__builtin_nansf" (floatType, [ charConstPtrType ], false);
- H.add h "__builtin_nansl" (longDoubleType, [ charConstPtrType ], false);
- H.add h "__builtin_next_arg" ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false) (* When we parse builtin_next_arg we drop the argument *);
- H.add h "__builtin_object_size" (sizeType, [ voidPtrType; intType ], false);
- H.add h "__builtin_parity" (intType, [ uintType ], false);
- H.add h "__builtin_parityl" (intType, [ ulongType ], false);
- H.add h "__builtin_parityll" (intType, [ ulongLongType ], false);
- H.add h "__builtin_popcount" (intType, [ uintType ], false);
- H.add h "__builtin_popcountl" (intType, [ ulongType ], false);
- H.add h "__builtin_popcountll" (intType, [ ulongLongType ], false);
- H.add h "__builtin_powi" (doubleType, [ doubleType; intType ], false);
- H.add h "__builtin_powif" (floatType, [ floatType; intType ], false);
- H.add h "__builtin_powil" (longDoubleType, [ longDoubleType; intType ], false);
- H.add h "__builtin_prefetch" (voidType, [ voidConstPtrType ], true);
- H.add h "__builtin_return" (voidType, [ voidConstPtrType ], false);
- H.add h "__builtin_return_address" (voidPtrType, [ uintType ], false);
- H.add h "__builtin_extract_return_addr" (voidPtrType, [ voidPtrType ], false);
- H.add h "__builtin_frob_return_address" (voidPtrType, [ voidPtrType ], false);
- H.add h "__builtin_sin" (doubleType, [ doubleType ], false);
- H.add h "__builtin_sinf" (floatType, [ floatType ], false);
- H.add h "__builtin_sinl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_sinh" (doubleType, [ doubleType ], false);
- H.add h "__builtin_sinhf" (floatType, [ floatType ], false);
- H.add h "__builtin_sinhl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_sqrt" (doubleType, [ doubleType ], false);
- H.add h "__builtin_sqrtf" (floatType, [ floatType ], false);
- H.add h "__builtin_sqrtl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_stpcpy" (charPtrType, [ charPtrType; charConstPtrType ], false);
- H.add h "__builtin_strchr" (charPtrType, [ charPtrType; intType ], false);
- H.add h "__builtin_strcmp" (intType, [ charConstPtrType; charConstPtrType ], false);
- H.add h "__builtin_strcpy" (charPtrType, [ charPtrType; charConstPtrType ], false);
- H.add h "__builtin_strlen" (sizeType, [ charConstPtrType ], false);
- H.add h "__builtin_strcspn" (sizeType, [ charConstPtrType; charConstPtrType ], false);
- H.add h "__builtin_strncat" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
- H.add h "__builtin_strncmp" (intType, [ charConstPtrType; charConstPtrType; sizeType ], false);
- H.add h "__builtin_strncpy" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
- H.add h "__builtin_strspn" (sizeType, [ charConstPtrType; charConstPtrType ], false);
- H.add h "__builtin_strpbrk" (charPtrType, [ charConstPtrType; charConstPtrType ], false);
- (* When we parse builtin_types_compatible_p, we change its interface *)
- H.add h "__builtin_types_compatible_p"
- (intType, [ !typeOfSizeOf;(* Sizeof the type *)
- !typeOfSizeOf (* Sizeof the type *) ],
- false);
- H.add h "__builtin_tan" (doubleType, [ doubleType ], false);
- H.add h "__builtin_tanf" (floatType, [ floatType ], false);
- H.add h "__builtin_tanl" (longDoubleType, [ longDoubleType ], false);
- H.add h "__builtin_tanh" (doubleType, [ doubleType ], false);
- H.add h "__builtin_tanhf" (floatType, [ floatType ], false);
- H.add h "__builtin_tanhl" (longDoubleType, [ longDoubleType ], false);
- (* MMX Builtins *)
- H.add h "__builtin_ia32_addps" (v4sfType, [v4sfType; v4sfType], false);
- H.add h "__builtin_ia32_subps" (v4sfType, [v4sfType; v4sfType], false);
- H.add h "__builtin_ia32_mulps" (v4sfType, [v4sfType; v4sfType], false);
- H.add h "__builtin_ia32_unpckhps" (v4sfType, [v4sfType; v4sfType], false);
- H.add h "__builtin_ia32_unpcklps" (v4sfType, [v4sfType; v4sfType], false);
- H.add h "__builtin_ia32_maxps" (v4sfType, [v4sfType; v4sfType], false);
- (* Atomic Builtins
- These builtins have an overloaded return type, hence the "magic" void type
- with __overloaded__ attribute, used to infer return type from parameters in
- cabs2cil.ml.
- For the same reason, we do not specify the type of the parameters. *)
- H.add h "__sync_fetch_and_add" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_fetch_and_sub" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_fetch_and_or" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_fetch_and_and" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_fetch_and_xor" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_fetch_and_nand" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_add_and_fetch" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_sub_and_fetch" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_or_and_fetch" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_and_and_fetch" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_xor_and_fetch" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_nand_and_fetch" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_bool_compare_and_swap" (TInt (IBool, []), [ ], true);
- H.add h "__sync_val_compare_and_swap" (TVoid[Attr("overloaded",[])], [ ],
- true);
- H.add h "__sync_synchronize" (voidType, [ ], true);
- H.add h "__sync_lock_test_and_set" (TVoid[Attr("overloaded",[])], [ ], true);
- H.add h "__sync_lock_release" (voidType, [ ], true);
- (* __atomic builtins for various bit widths
- Most __atomic functions are offered for various bit widths, using
- a different suffix for each concrete bit width: "_1", "_2", and
- so on up to "_16". Each of these functions also exists in a form
- with no bit width specified, and occasionally with a bit width
- suffix of "_n".
- Note that these __atomic functions are not really va_arg, but we
- set the va_arg flag nonetheless because it prevents CIL from
- trying to check the type of parameters against the prototype.
- *)
- let addAtomicForWidths baseName ?n ~none ~num () =
- (* ?n gives the return type to be used with the "_n" suffix, if any *)
- (* ~none gives the return type to be used with no suffix *)
- (* ~num gives the return type to be used with the "_1" through "_16" suffixes *)
- let addWithSuffix suffix returnType =
- let identifier = "__atomic_" ^ baseName ^ suffix in
- H.add h identifier (returnType, [], true)
- in
- List.iter begin
- fun bitWidth ->
- let suffix = "_" ^ (string_of_int bitWidth) in
- addWithSuffix suffix num
- end [1; 2; 4; 8; 16];
- addWithSuffix "" none;
- match n with
- | None -> ()
- | Some typ -> addWithSuffix "_n" typ
- in
- let anyType = TVoid [Attr("overloaded", [])] in
- (* binary operations combined with a fetch of either the old or new value *)
- List.iter begin
- fun operation ->
- addAtomicForWidths ("fetch_" ^ operation) ~none:anyType ~num:anyType ();
- addAtomicForWidths (operation ^ "_fetch") ~none:anyType ~num:anyType ()
- end ["add"; "and"; "nand"; "or"; "sub"; "xor"];
- (* other atomic operations provided at various bit widths *)
- addAtomicForWidths "compare_exchange" ~none:boolType ~n:boolType ~num:boolType ();
- addAtomicForWidths "exchange" ~none:voidType ~n:anyType ~num:anyType ();
- addAtomicForWidths "load" ~none:voidType ~n:anyType ~num:anyType ();
- addAtomicForWidths "store" ~none:voidType ~n:voidType ~num:voidType ();
- (* Some atomic builtins actually have a decent, C-compatible type *)
- H.add h "__atomic_test_and_set" (boolType, [voidPtrType; intType], false);
- H.add h "__atomic_clear" (voidType, [boolPtrType; intType], false);
- H.add h "__atomic_thread_fence" (voidType, [intType], false);
- H.add h "__atomic_signal_fence" (voidType, [intType], false);
- H.add h "__atomic_always_lock_free" (boolType, [sizeType; voidPtrType], false);
- H.add h "__atomic_is_lock_free" (boolType, [sizeType; voidPtrType], false);
- H.add h "__atomic_feraiseexcept" (voidType, [intType], false);
- if hasbva then begin
- H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false);
- H.add h "__builtin_varargs_start"
- (voidType, [ TBuiltin_va_list [] ], false);
- (* When we parse builtin_{va,stdarg}_start, we drop the second argument *)
- H.add h "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false);
- H.add h "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ],
- false);
- (* When we parse builtin_va_arg we change its interface *)
- H.add h "__builtin_va_arg" (voidType, [ TBuiltin_va_list [];
- !typeOfSizeOf;(* Sizeof the type *)
- voidPtrType; (* Ptr to res *) ],
- false);
- H.add h "__builtin_va_copy" (voidType, [ TBuiltin_va_list [];
- TBuiltin_va_list [] ],
- false);
- end;
- H.add h "__builtin_apply_args" (voidPtrType, [ ], false);
- let fnPtr = TPtr(TFun (voidType, None, false, []), []) in
- H.add h "__builtin_apply" (voidPtrType, [fnPtr; voidPtrType; sizeType], false);
- H.add h "__builtin_va_arg_pack" (intType, [ ], false);
- H.add h "__builtin_va_arg_pack_len" (intType, [ ], false);
- ()
- (** Construct a hash with the builtins *)
- let initMsvcBuiltins () : unit =
- if not !initCIL_called then
- E.s (bug "Call initCIL before initGccBuiltins");
- if H.length builtinFunctions <> 0 then
- E.s (bug "builtins already initialized.");
- let h = builtinFunctions in
- (** Take a number of wide string literals *)
- H.add h "__annotation" (voidType, [ ], true);
- ()
- (** This is used as the location of the prototypes of builtin functions. *)
- let builtinLoc: location = { line = 1;
- file = "<compiler builtins>";
- byte = 0;}
- let pTypeSig : (typ -> typsig) ref =
- ref (fun _ -> E.s (E.bug "pTypeSig not initialized"))
- (** A printer interface for CIL trees. Create instantiations of
- * this type by specializing the class {!Cil.defaultCilPrinter}. *)
- class type cilPrinter = object
- method setCurrentFormals : varinfo list -> unit
- method setPrintInstrTerminator : string -> unit
- method getPrintInstrTerminator : unit -> string
- method pVDecl: unit -> varinfo -> doc
- (** Invoked for each variable declaration. Note that variable
- * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo]
- * in formals of function types, and the formals and locals for function
- * definitions. *)
- method pVar: varinfo -> doc
- (** Invoked on each variable use. *)
- method pLval: unit -> lval -> doc
- (** Invoked on each lvalue occurence *)
- method pOffset: doc -> offset -> doc
- (** Invoked on each offset occurence. The second argument is the base. *)
- method pInstr: unit -> instr -> doc
- (** Invoked on each instruction occurrence. *)
- method pStmt: unit -> stmt -> doc
- (** Control-flow statement. This is used by
- * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *)
- method dStmt: out_channel -> int -> stmt -> unit
- (** Dump a control-flow statement to a file with a given indentation. This is used by
- * {!Cil.dumpGlobal}. *)
- method dBlock: out_channel -> int -> block -> unit
- (** Dump a control-flow block to a file with a given indentation. This is
- * used by {!Cil.dumpGlobal}. *)
- method pBlock: unit -> block -> Pretty.doc
- (** Print a block. *)
- method pGlobal: unit -> global -> doc
- (** Global (vars, types, etc.). This can be slow and is used only by
- * {!Cil.printGlobal} but by {!Cil.dumpGlobal} for everything else except
- * [GVar] and [GFun]. *)
- method dGlobal: out_channel -> global -> unit
- (** Dump a global to a file. This is used by {!Cil.dumpGlobal}. *)
- method pFieldDecl: unit -> fieldinfo -> doc
- (** A field declaration *)
- method pType: doc option -> unit -> typ -> doc
- (* Use of some type in some declaration. The first argument is used to print
- * the declared element, or is None if we are just printing a type with no
- * name being declared. Note that for structure/union and enumeration types
- * the definition of the composite type is not visited. Use [vglob] to
- * visit it. *)
- method pAttr: attribute -> doc * bool
- (** Attribute. Also return an indication whether this attribute must be
- * printed inside the __attribute__ list or not. *)
-
- method pAttrParam: unit -> attrparam -> doc
- (** Attribute paramter *)
-
- method pAttrs: unit -> attributes -> doc
- (** Attribute lists *)
- method pLabel: unit -> label -> doc
- (** Label *)
- method pLineDirective: ?forcefile:bool -> location -> Pretty.doc
- (** Print a line-number. This is assumed to come always on an empty line.
- * If the forcefile argument is present and is true then the file name
- * will be printed always. Otherwise the file name is printed only if it
- * is different from the last time time this function is called. The last
- * file name is stored in a private field inside the cilPrinter object. *)
- method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc
- (** Print a statement kind. The code to be printed is given in the
- * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument
- * records the statement which follows the one being printed;
- * {!Cil.defaultCilPrinterClass} uses this information to prettify
- * statement printing in certain special cases. *)
- method pExp: unit -> exp -> doc
- (** Print expressions *)
- method pInit: unit -> init -> doc
- (** Print initializers. This can be slow and is used by
- * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *)
- method dInit: out_channel -> int -> init -> unit
- (** Dump a global to a file with a given indentation. This is used by
- * {!Cil.dumpGlobal}. *)
- end
- class defaultCilPrinterClass : cilPrinter = object (self)
- val mutable currentFormals : varinfo list = []
- method private getLastNamedArgument (s:string) : exp =
- match List.rev currentFormals with
- f :: _ -> Lval (var f)
- | [] ->
- E.s (bug "Cannot find the last named argument when printing call to %s\n" s)
- method private setCurrentFormals (fms : varinfo list) =
- currentFormals <- fms
- (*** VARIABLES ***)
- (* variable use *)
- method pVar (v:varinfo) = text v.vname
- (* variable declaration *)
- method pVDecl () (v:varinfo) =
- let stom, rest = separateStorageModifiers v.vattr in
- (* First the storage modifiers *)
- text (if v.vinline then "__inline " else "")
- ++ d_storage () v.vstorage
- ++ (self#pAttrs () stom)
- ++ (self#pType (Some (text v.vname)) () v.vtype)
- ++ text " "
- ++ self#pAttrs () rest
- (*** L-VALUES ***)
- method pLval () (lv:lval) = (* lval (base is 1st field) *)
- match lv with
- Var vi, o -> self#pOffset (self#pVar vi) o
- | Mem e, Field(fi, o) ->
- self#pOffset
- ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o
- | Mem e, NoOffset ->
- text "*" ++ self#pExpPrec derefStarLevel () e
- | Mem e, o ->
- self#pOffset
- (text "(*" ++ self#pExpPrec derefStarLevel () e ++ text ")") o
- (** Offsets **)
- method pOffset (base: doc) = function
- | NoOffset -> base
- | Field (fi, o) ->
- self#pOffset (base ++ text "." ++ text fi.fname) o
- | Index (e, o) ->
- self#pOffset (base ++ text "[" ++ self#pExp () e ++ text "]") o
- method private pLvalPrec (contextprec: int) () lv =
- if getParenthLevel (Lval(lv)) >= contextprec then
- text "(" ++ self#pLval () lv ++ text ")"
- else
- self#pLval () lv
- (*** EXPRESSIONS ***)
- method pExp () (e: exp) : doc =
- let level = getParenthLevel e in
- match e with
- Const(c) -> d_const () c
- | Lval(l) -> self#pLval () l
- | UnOp(u,e1,_) ->
- (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1)
-
- | BinOp(b,e1,e2,_) ->
- align
- ++ (self#pExpPrec level () e1)
- ++ chr ' '
- ++ (d_binop () b)
- ++ chr ' '
- ++ (self#pExpPrec level () e2)
- ++ unalign
- | Question(e1,e2,e3,_) ->
- (self#pExpPrec level () e1)
- ++ text " ? "
- ++ (self#pExpPrec level () e2)
- ++ text " : "
- ++ (self#pExpPrec level () e3)
- | CastE(t,e) ->
- text "("
- ++ self#pType None () t
- ++ text ")"
- ++ self#pExpPrec level () e
- | SizeOf (t) ->
- text "sizeof(" ++ self#pType None () t ++ chr ')'
- | SizeOfE (Lval (Var fv, NoOffset)) when fv.vname = "__builtin_va_arg_pack" && (not !printCilAsIs) ->
- text "__builtin_va_arg_pack()"
- | SizeOfE (e) ->
- text "sizeof(" ++ self#pExp () e ++ chr ')'
- | SizeOfStr s ->
- text "sizeof(" ++ d_const () (CStr s) ++ chr ')'
- | AlignOf (t) ->
- text "__alignof__(" ++ self#pType None () t ++ chr ')'
- | AlignOfE (e) ->
- text "__alignof__(" ++ self#pExp () e ++ chr ')'
- | AddrOf(lv) ->
- text "& " ++ (self#pLvalPrec addrOfLevel () lv)
- | AddrOfLabel(sref) -> begin
- (* Grab one of the labels *)
- let rec pickLabel = function
- [] -> None
- | Label (l, _, _) :: _ -> Some l
- | _ :: rest -> pickLabel rest
- in
- match pickLabel !sref.labels with
- Some lbl -> text ("&& " ^ lbl)
- | None ->
- ignore (error "Cannot find label for target of address of label");
- text "&& __invalid_label"
- end
-
- | StartOf(lv) -> self#pLval () lv
- (* Print an expression, given the precedence of the context in which it
- * appears. *)
- method private pExpPrec (contextprec: int) () (e: exp) =
- let thisLevel = getParenthLevel e in
- let needParens =
- if thisLevel >= contextprec then
- true
- else if contextprec == bitwiseLevel then
- (* quiet down some GCC warnings *)
- thisLevel == additiveLevel || thisLevel == comparativeLevel
- else
- false
- in
- if needParens then
- chr '(' ++ self#pExp () e ++ chr ')'
- else
- self#pExp () e
- method pInit () = function
- SingleInit e -> self#pExp () e
- | CompoundInit (t, initl) ->
- (* We do not print the type of the Compound *)
- (*
- let dinit e = d_init () e in
- dprintf "{@[%a@]}"
- (docList ~sep:(chr ',' ++ break) dinit) initl
- *)
- let printDesignator =
- if not !msvcMode then begin
- (* Print only for union when we do not initialize the first field *)
- match unrollType t, initl with
- TComp(ci, _), [(Field(f, NoOffset), _)] ->
- if not (ci.cstruct) && ci.cfields != [] &&
- (List.hd ci.cfields) != f then
- true
- else
- false
- | _ -> false
- end else
- false
- in
- let d_oneInit = function
- Field(f, NoOffset), i ->
- (if printDesignator then
- text ("." ^ f.fname ^ " = ")
- else nil) ++ self#pInit () i
- | Index(e, NoOffset), i ->
- (if printDesignator then
- text "[" ++ self#pExp () e ++ text "] = " else nil) ++
- self#pInit () i
- | _ -> E.s (unimp "Trying to print malformed initializer")
- in
- chr '{' ++ (align
- ++ ((docList ~sep:(chr ',' ++ break) d_oneInit) () initl)
- ++ unalign)
- ++ chr '}'
- (*
- | ArrayInit (_, _, il) ->
- chr '{' ++ (align
- ++ ((docList (chr ',' ++ break) (self#pInit ())) () il)
- ++ unalign)
- ++ chr '}'
- *)
- (* dump initializers to a file. *)
- method dInit (out: out_channel) (ind: int) (i: init) =
- (* Dump an array *)
- let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) =
- let onALine = (* How many elements on a line *)
- match unrollType bt with TComp _ | TArray _ -> 1 | _ -> 4
- in
- let rec outputElements (isfirst: bool) (room_on_line: int) = function
- [] -> output_string out "}"
- | (i: 'a) :: rest ->
- if not isfirst then output_string out ", ";
- let new_room_on_line =
- if room_on_line == 0 then begin
- output_string out "\n"; output_string out (String.make ind ' ');
- onALine - 1
- end else
- room_on_line - 1
- in
- self#dInit out (ind + 2) (getelem i);
- outputElements false new_room_on_line rest
- in
- output_string out "{ ";
- outputElements true onALine il
- in
- match i with
- SingleInit e ->
- fprint out !lineLength (indent ind (self#pExp () e))
- | CompoundInit (t, initl) -> begin
- match unrollType t with
- TArray(bt, _, _) ->
- dumpArray bt initl (fun (_, i) -> i)
- | _ ->
- (* Now a structure or a union *)
- fprint out !lineLength (indent ind (self#pInit () i))
- end
- (*
- | ArrayInit (bt, len, initl) -> begin
- (* If the base type does not contain structs then use the pInit
- match unrollType bt with
- TComp _ | TArray _ ->
- dumpArray bt initl (fun x -> x)
- | _ -> *)
- fprint out !lineLength (indent ind (self#pInit () i))
- end
- *)
-
- (** What terminator to print after an instruction. sometimes we want to
- * print sequences of instructions separated by comma *)
- val mutable printInstrTerminator = ";"
- method private setPrintInstrTerminator (term : string) =
- printInstrTerminator <- term
- method private getPrintInstrTerminator () = printInstrTerminator
- (*** INSTRUCTIONS ****)
- method pInstr () (i:instr) = (* imperative instruction *)
- match i with
- | Set(lv,e,l) -> begin
- (* Be nice to some special cases *)
- match e with
- BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(one,_,_)),_)
- when Util.equals lv lv' && one = Int64.one && not !printCilAsIs ->
- self#pLineDirective l
- ++ self#pLvalPrec indexLevel () lv
- ++ text (" ++" ^ printInstrTerminator)
- | BinOp((MinusA|MinusPI),Lval(lv'),
- Const(CInt64(one,_,_)), _)
- when Util.equals lv lv' && one = Int64.one && not !printCilAsIs ->
- self#pLineDirective l
- ++ self#pLvalPrec indexLevel () lv
- ++ text (" --" ^ printInstrTerminator)
- | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_)
- when Util.equals lv lv' && mone = Int64.minus_one
- && not !printCilAsIs ->
- self#pLineDirective l
- ++ self#pLvalPrec indexLevel () lv
- ++ text (" --" ^ printInstrTerminator)
- | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor|
- Mult|Div|Mod|Shiftlt|Shiftrt) as bop,
- Lval(lv'),e,_) when Util.equals lv lv'
- && not !printCilAsIs ->
- self#pLineDirective l
- ++ self#pLval () lv
- ++ text " " ++ d_binop () bop
- ++ text "= "
- ++ self#pExp () e
- ++ text printInstrTerminator
-
- | _ ->
- self#pLineDirective l
- ++ self#pLval () lv
- ++ text " = "
- ++ self#pExp () e
- ++ text printInstrTerminator
-
- end
- (* In cabs2cil we have turned the call to builtin_va_arg into a
- * three-argument call: the last argument is the address of the
- * destination *)
- | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l)
- when vi.vname = "__builtin_va_arg" && not !printCilAsIs ->
- let destlv = match stripCasts adest with
- AddrOf destlv -> destlv
- (* If this fails, it's likely that an extension interfered
- with the AddrOf *)
- | _ -> E.s (E.bug
- "%a: Encountered unexpected call to %s with dest %a\n"
- d_loc l vi.vname self#pExp adest)
- in
- self#pLineDirective l
- ++ self#pLval () destlv ++ text " = "
-
- (* Now the function name *)
- ++ text "__builtin_va_arg"
- ++ text "(" ++ (align
- (* Now the arguments *)
- ++ self#pExp () dest
- ++ chr ',' ++ break
- ++ self#pType None () t
- ++ unalign)
- ++ text (")" ^ printInstrTerminator)
- (* In cabs2cil we have dropped the last argument in the call to
- * __builtin_va_start and __builtin_stdarg_start. *)
- | Call(None, Lval(Var vi, NoOffset), [marker], l)
- when ((vi.vname = "__builtin_stdarg_start" ||
- vi.vname = "__builtin_va_start") && not !printCilAsIs) ->
- if currentFormals <> [] then begin
- let last = self#getLastNamedArgument vi.vname in
- self#pInstr () (Call(None,Lval(Var vi,NoOffset),[marker; last],l))
- end
- else begin
- (* We can't print this call because someone called pInstr outside
- of a pFunDecl, so we don't know what the formals of the current
- function are. Just put in a placeholder for now; this isn't
- valid C. *)
- self#pLineDirective l
- ++ dprintf
- "%s(%a, /* last named argument of the function calling %s */)"
- vi.vname self#pExp marker vi.vname
- ++ text printInstrTerminator
- end
- (* In cabs2cil we have dropped the last argument in the call to
- * __builtin_next_arg. *)
- | Call(res, Lval(Var vi, NoOffset), [ ], l)
- when vi.vname = "__builtin_next_arg" && not !printCilAsIs -> begin
- let last = self#getLastNamedArgument vi.vname in
- self#pInstr () (Call(res,Lval(Var vi,NoOffset),[last],l))
- end
- (* In cparser we have turned the call to
- * __builtin_types_compatible_p(t1, t2) into
- * __builtin_types_compatible_p(sizeof t1, sizeof t2), so that we can
- * represent the types as expressions.
- * Remove the sizeofs when printing. *)
- | Call(dest, Lval(Var vi, NoOffset), [SizeOf t1; SizeOf t2], l)
- when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs ->
- self#pLineDirective l
- (* Print the destination *)
- ++ (match dest with
- None -> nil
- | Some lv -> self#pLval () lv ++ text " = ")
- (* Now the call itself *)
- ++ dprintf "%s(%a, %a)" vi.vname
- (self#pType None) t1 (self#pType None) t2
- ++ text printInstrTerminator
- | Call(_, Lval(Var vi, NoOffset), _, l)
- when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs ->
- E.s (bug "__builtin_types_compatible_p: cabs2cil should have added sizeof to the arguments.")
-
- | Call(dest,e,args,l) ->
- self#pLineDirective l
- ++ (match dest with
- None -> nil
- | Some lv ->
- self#pLval () lv ++ text " = " ++
- (* Maybe we need to print a cast *)
- (let destt = typeOfLval lv in
- match unrollType (typeOf e) with
- TFun (rt, _, _, _)
- when not (Util.equals (!pTypeSig rt)
- (!pTypeSig destt)) ->
- text "(" ++ self#pType None () destt ++ text ")"
- | _ -> nil))
- (* Now the function name *)
- ++ (let ed = self#pExp () e in
- match e with
- Lval(Var _, _) -> ed
- | _ -> text "(" ++ ed ++ text ")")
- ++ text "(" ++
- (align
- (* Now the arguments *)
- ++ (docList ~sep:(chr ',' ++ break)
- (self#pExp ()) () args)
- ++ unalign)
- ++ text (")" ^ printInstrTerminator)
- | Asm(attrs, tmpls, outs, ins, clobs, l) ->
- if !msvcMode then
- self#pLineDirective l
- ++ text "__asm {"
- ++ (align
- ++ (docList ~sep:line text () tmpls)
- ++ unalign)
- ++ text ("}" ^ printInstrTerminator)
- else
- self#pLineDirective l
- ++ text ("__asm__ ")
- ++ self#pAttrs () attrs
- ++ text " ("
- ++ (align
- ++ (docList ~sep:line
- (fun x -> text ("\"" ^ escape_string x ^ "\""))
- () tmpls)
- ++
- (if outs = [] && ins = [] && clobs = [] then
- chr ':'
- else
- (text ": "
- ++ (docList ~sep:(chr ',' ++ break)
- (fun (idopt, c, lv) ->
- text(match idopt with
- None -> ""
- | Some id -> "[" ^ id ^ "] "
- ) ++
- text ("\"" ^ escape_string c ^ "\" (")
- ++ self#pLval () lv
- ++ text ")") () outs)))
- ++
- (if ins = [] && clobs = [] then
- nil
- else
- (text ": "
- ++ (docList ~sep:(chr ',' ++ break)
- (fun (idopt, c, e) ->
- text(match idopt with
- None -> ""
- | Some id -> "[" ^ id ^ "] "
- ) ++
- text ("\"" ^ escape_string c ^ "\" (")
- ++ self#pExp () e
- ++ text ")") () ins)))
- ++
- (if clobs = [] then nil
- else
- (text ": "
- ++ (docList ~sep:(chr ',' ++ break)
- (fun c -> text ("\"" ^ escape_string c ^ "\""))
- ()
- clobs)))
- ++ unalign)
- ++ text (")" ^ printInstrTerminator)
-
- (**** STATEMENTS ****)
- method pStmt () (s:stmt) = (* control-flow statement *)
- self#pStmtNext invalidStmt () s
- method dStmt (out: out_channel) (ind: int) (s:stmt) : unit =
- fprint out !lineLength (indent ind (self#pStmt () s))
- method dBlock (out: out_channel) (ind: int) (b:block) : unit =
- fprint out !lineLength (indent ind (align ++ self#pBlock () b))
- method private pStmtNext (next: stmt) () (s: stmt) =
- (* print the labels *)
- ((docList ~sep:line (fun l -> self#pLabel () l)) () s.labels)
- (* print the statement itself. If the labels are non-empty and the
- * statement is empty, print a semicolon *)
- ++
- (if s.skind = Instr [] && s.labels <> [] then
- text ";"
- else
- (if s.labels <> [] then line else nil)
- ++ self#pStmtKind next () s.skind)
- method private pLabel () = function
- Label (s, _, true) -> text (s ^ ": ")
- | Label (s, _, false) -> text (s ^ ": /* CIL Label */ ")
- | Case (e, _) -> text "case " ++ self#pExp () e ++ text ": "
- | CaseRange (e1, e2, _) -> text "case " ++ self#pExp () e1 ++ text " ... "
- ++ self#pExp () e2 ++ text ": "
- | Default _ -> text "default: "
- (* The pBlock will put the unalign itself *)
- method pBlock () (blk: block) =
- let rec dofirst () = function
- [] -> nil
- | [x] -> self#pStmtNext invalidStmt () x
- | x :: rest -> dorest nil x rest
- and dorest acc prev = function
- [] -> acc ++ (self#pStmtNext invalidStmt () prev)
- | x :: rest ->
- dorest (acc ++ (self#pStmtNext x () prev) ++ line)
- x rest
- in
- (* Let the host of the block decide on the alignment. The d_block will
- * pop the alignment as well *)
- text "{"
- ++
- (if blk.battrs <> [] then
- self#pAttrsGen true blk.battrs
- else nil)
- ++ line
- ++ (dofirst () blk.bstmts)
- ++ unalign ++ line ++ text "}"
-
- (* Store here the name of the last file printed in a line number. This is
- * private to the object *)
- val mutable lastFileName = ""
- val mutable lastLineNumber = -1
- (* Make sure that you only call self#pLineDirective on an empty line *)
- method pLineDirective ?(forcefile=false) l =
- currentLoc := l;
- match !lineDirectiveStyle with
- | None -> nil
- | Some _ when l.line <= 0 -> nil
- (* Do not print lineComment if the same line as above *)
- | Some LineCommentSparse when l.line = lastLineNumber -> nil
- | Some style ->
- let directive =
- match style with
- | LineComment | LineCommentSparse -> text "//#line "
- | LinePreprocessorOutput when not !msvcMode -> chr '#'
- | LinePreprocessorOutput | LinePreprocessorInput -> text "#line"
- in
- lastLineNumber <- l.line;
- let filename =
- if forcefile || l.file <> lastFileName then
- begin
- lastFileName <- l.file;
- text " \"" ++ text l.file ++ text "\""
- end
- else
- nil
- in
- leftflush ++ directive ++ chr ' ' ++ num l.line ++ filename ++ line
- method private pIfConditionThen loc condition thenBlock =
- self#pLineDirective loc
- ++ text "if"
- ++ (align
- ++ text " ("
- ++ self#pExp () condition
- ++ text ") "
- ++ self#pBlock () thenBlock)
- method private pStmtKind (next: stmt) () = function
- Return(None, l) ->
- self#pLineDirective l
- ++ text "return;"
- | Return(Some e, l) ->
- self#pLineDirective l
- ++ text "return ("
- ++ self#pExp () e
- ++ text ");"
-
- | Goto (sref, l) -> begin
- (* Grab one of the labels *)
- let rec pickLabel = function
- [] -> None
- | Label (l, _, _) :: _ -> Some l
- | _ :: rest -> pickLabel rest
- in
- match pickLabel !sref.labels with
- Some lbl -> self#pLineDirective l ++ text ("goto " ^ lbl ^ ";")
- | None ->
- ignore (error "Cannot find label for target of goto");
- text "goto __invalid_label;"
- end
- | ComputedGoto(e, l) ->
- self#pLineDirective l
- ++ text "goto *("
- ++ self#pExp () e
- ++ text ");"
- | Break l ->
- self#pLineDirective l
- ++ text "break;"
- | Continue l ->
- self#pLineDirective l
- ++ text "continue;"
- | Instr il ->
- align
- ++ (docList ~sep:line (fun i -> self#pInstr () i) () il)
- ++ unalign
- | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs ->
- self#pIfConditionThen l be t
-
- | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}];
- battrs=[]},l)
- when !gref == next && not !printCilAsIs ->
- self#pIfConditionThen l be t
- | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs ->
- self#pIfConditionThen l (UnOp(LNot,be,intType)) e
- | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}];
- battrs=[]},e,l)
- when !gref == next && not !printCilAsIs ->
- self#pIfConditionThen l (UnOp(LNot,be,intType)) e
-
- | If(be,t,e,l) ->
- self#pIfConditionThen l be t
- ++ (match e with
- { bstmts=[{skind=If _} as elsif]; battrs=[] } ->
- text " else"
- ++ line (* Don't indent else-ifs *)
- ++ self#pStmtNext next () elsif
- | _ ->
- text " " (* sm: indent next code 2 spaces (was 4) *)
- ++ align
- ++ text "else "
- ++ self#pBlock () e)
-
- | Switch(e,b,_,l) ->
- self#pLineDirective l
- ++ (align
- ++ text "switch ("
- ++ self#pExp () e
- ++ text ") "
- ++ self#pBlock () b)
- | Loop(b, l, _, _) -> begin
- (* Maybe the first thing is a conditional. Turn it into a WHILE *)
- try
- let term, bodystmts =
- let rec skipEmpty = function
- [] -> []
- | {skind=Instr [];labels=[]} :: rest -> skipEmpty rest
- | x -> x
- in
- (* Bill McCloskey: Do not remove the If if it has labels *)
- match skipEmpty b.bstmts with
- {skind=If(e,tb,fb,_); labels=[]} :: rest
- when not !printCilAsIs -> begin
- match skipEmpty tb.bstmts, skipEmpty fb.bstmts with
- [], {skind=Break _; labels=[]} :: _ -> e, rest
- | {skind=Break _; labels=[]} :: _, []
- -> UnOp(LNot, e, intType), rest
- | _ -> raise Not_found
- end
- | _ -> raise Not_found
- in
- self#pLineDirective l
- ++ text "wh"
- ++ (align
- ++ text "ile ("
- ++ self#pExp () term
- ++ text ") "
- ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs})
- with Not_found ->
- self#pLineDirective l
- ++ text "wh"
- ++ (align
- ++ text "ile (1) "
- ++ self#pBlock () b)
- end
- | Block b -> align ++ self#pBlock () b
-
- | TryFinally (b, h, l) ->
- self#pLineDirective l
- ++ text "__try "
- ++ align
- ++ self#pBlock () b
- ++ text " __fin" ++ align ++ text "ally "
- ++ self#pBlock () h
- | TryExcept (b, (il, e), h, l) ->
- self#pLineDirective l
- ++ text "__try "
- ++ align
- ++ self#pBlock () b
- ++ text " __e" ++ align ++ text "xcept(" ++ line
- ++ align
- (* Print the instructions but with a comma at the end, instead of
- * semicolon *)
- ++ (printInstrTerminator <- ",";
- let res =
- (docList ~sep:line (self#pInstr ())
- () il)
- in
- printInstrTerminator <- ";";
- res)
- ++ self#pExp () e
- ++ text ") " ++ unalign
- ++ self#pBlock () h
- (*** GLOBALS ***)
- method pGlobal () (g:global) : doc = (* global (vars, types, etc.) *)
- match g with
- | GFun (fundec, l) ->
- (* If the function has attributes then print a prototype because
- * GCC cannot accept function attributes in a definition *)
- let oldattr = fundec.svar.vattr in
- (* Always pring the file name before function declarations *)
- let proto =
- if oldattr <> [] then
- (self#pLineDirective l) ++ (self#pVDecl () fundec.svar)
- ++ chr ';' ++ line
- else nil in
- (* Temporarily remove the function attributes *)
- fundec.svar.vattr <- [];
- let body = (self#pLineDirective ~forcefile:true l)
- ++ (self#pFunDecl () fundec) in
- fundec.svar.vattr <- oldattr;
- proto ++ body ++ line
-
- | GType (typ, l) ->
- self#pLineDirective ~forcefile:true l ++
- text "typedef "
- ++ (self#pType (Some (text typ.tname)) () typ.ttype)
- ++ text ";\n"
- | GEnumTag (enum, l) ->
- self#pLineDirective l ++
- text "enum" ++ align ++ text (" " ^ enum.ename) ++
- text " {" ++ line
- ++ (docList ~sep:(chr ',' ++ line)
- (fun (n,i, loc) ->
- text (n ^ " = ")
- ++ self#pExp () i)
- () enum.eitems)
- ++ unalign ++ line ++ text "} "
- ++ self#pAttrs () enum.eattr ++ text";\n"
- | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *)
- self#pLineDirective l ++
- text "enum " ++ text enum.ename ++ chr ' '
- ++ self#pAttrs () enum.eattr ++ text ";\n"
- | GCompTag (comp, l) -> (* This is a definition of a tag *)
- let n = comp.cname in
- let su, su1, su2 =
- if comp.cstruct then "struct", "str", "uct"
- else "union", "uni", "on"
- in
- let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
- self#pLineDirective ~forcefile:true l ++
- text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod)
- ++ text n
- ++ text " {" ++ line
- ++ ((docList ~sep:line (self#pFieldDecl ())) ()
- comp.cfields)
- ++ unalign)
- ++ line ++ text "}" ++
- (self#pAttrs () rest_attr) ++ text ";\n"
- | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *)
- let su = if comp.cstruct then "struct " else "union " in
- let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
- self#pLineDirective l
- ++ text su ++ self#pAttrs () sto_mod
- ++ text comp.cname ++ chr ' '
- ++ self#pAttrs () rest_attr ++ text ";\n"
- | GVar (vi, io, l) ->
- self#pLineDirective ~forcefile:true l ++
- self#pVDecl () vi
- ++ chr ' '
- ++ (match io.init with
- None -> nil
- | Some i -> text " = " ++
- (let islong =
- match i with
- CompoundInit (_, il) when List.length il >= 8 -> true
- | _ -> false
- in
- if islong then
- line ++ self#pLineDirective l ++ text " "
- else nil) ++
- (self#pInit () i))
- ++ text ";\n"
-
- (* print global variable 'extern' declarations, and function prototypes *)
- | GVarDecl (vi, l) ->
- if not !printCilAsIs && H.mem builtinFunctions vi.vname then begin
- (* Compiler builtins need no prototypes. Just print them in
- comments. *)
- text "/* compiler builtin: \n " ++
- (self#pVDecl () vi)
- ++ text "; */\n"
-
- end else
- self#pLineDirective l ++
- (self#pVDecl () vi)
- ++ text ";\n"
- | GAsm (s, l) ->
- self#pLineDirective l ++
- text ("__asm__(\"" ^ escape_string s ^ "\");\n")
- | GPragma (Attr(an, args), l) ->
- (* sm: suppress printing pragmas that gcc does not understand *)
- (* assume anything starting with "ccured" is ours *)
- (* also don't print the 'combiner' pragma *)
- (* nor 'cilnoremove' *)
- let suppress =
- not !print_CIL_Input &&
- not !msvcMode &&
- ((startsWith "box" an) ||
- (startsWith "ccured" an) ||
- (an = "merger") ||
- (an = "cilnoremove")) in
- let d =
- match an, args with
- | _, [] ->
- text an
- | "weak", [ACons (symbol, [])] ->
- text "weak " ++ text symbol
- | _ ->
- text (an ^ "(")
- ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args
- ++ text ")"
- in
- self#pLineDirective l
- ++ (if suppress then text "/* " else text "")
- ++ (text "#pragma ")
- ++ d
- ++ (if suppress then text " */\n" else text "\n")
- | GText s ->
- if s <> "//" then
- text s ++ text "\n"
- else
- nil
- method dGlobal (out: out_channel) (g: global) : unit =
- (* For all except functions and variable with initializers, use the
- * pGlobal *)
- match g with
- GFun (fdec, l) ->
- (* If the function has attributes then print a prototype because
- * GCC cannot accept function attributes in a definition *)
- let oldattr = fdec.svar.vattr in
- let proto =
- if oldattr <> [] then
- (self#pLineDirective l) ++ (self#pVDecl () fdec.svar)
- ++ chr ';' ++ line
- else nil in
- fprint out !lineLength
- (proto ++ (self#pLineDirective ~forcefile:true l));
- (* Temporarily remove the function attributes *)
- fdec.svar.vattr <- [];
- fprint out !lineLength (self#pFunDecl () fdec);
- fdec.svar.vattr <- oldattr;
- output_string out "\n"
- | GVar (vi, {init = Some i}, l) -> begin
- fprint out !lineLength
- (self#pLineDirective ~forcefile:true l ++
- self#pVDecl () vi
- ++ text " = "
- ++ (let islong =
- match i with
- CompoundInit (_, il) when List.length il >= 8 -> true
- | _ -> false
- in
- if islong then
- line ++ self#pLineDirective l ++ text " "
- else nil));
- self#dInit out 3 i;
- output_string out ";\n"
- end
- | g -> fprint out !lineLength (self#pGlobal () g)
- method pFieldDecl () fi =
- (self#pType
- (Some (text (if fi.fname = missingFieldName then "" else fi.fname)))
- ()
- fi.ftype)
- ++ text " "
- ++ (match fi.fbitfield with None -> nil
- | Some i -> text ": " ++ num i ++ text " ")
- ++ self#pAttrs () fi.fattr
- ++ text ";"
-
- method private pFunDecl () f =
- self#pVDecl () f.svar
- ++ line
- ++ text "{ "
- ++ (align
- (* locals. *)
- ++ line
- ++ (docList ~sep:line
- (fun vi -> match vi.vinit.init with
- | None -> self#pVDecl () vi ++ text ";"
- | Some i -> self#pVDecl () vi ++ text " = " ++
- self#pInit () i ++ text ";")
- () f.slocals)
- ++ line ++ line
- (* the body *)
- ++ ((* remember the declaration *) currentFormals <- f.sformals;
- let body = self#pBlock () f.sbody in
- currentFormals <- [];
- body))
- ++ line
- ++ text "}"
- (***** PRINTING DECLARATIONS and TYPES ****)
-
- method pType (nameOpt: doc option) (* Whether we are declaring a name or
- * we are just printing a type *)
- () (t:typ) = (* use of some type *)
- let name = match nameOpt with None -> nil | Some d -> d in
- let printAttributes (a: attributes) =
- let pa = self#pAttrs () a in
- match nameOpt with
- | None when not !print_CIL_Input && not !msvcMode ->
- (* Cannot print the attributes in this case because gcc does not
- * like them here, except if we are printing for CIL, or for MSVC.
- * In fact, for MSVC we MUST print attributes such as __stdcall *)
- if pa = nil then nil else
- text "/*" ++ pa ++ text "*/"
- | _ -> pa
- in
- match t with
- TVoid a ->
- text "void"
- ++ self#pAttrs () a
- ++ text " "
- ++ name
- | TInt (ikind,a) ->
- d_ikind () ikind
- ++ self#pAttrs () a
- ++ text " "
- ++ name
- | TFloat(fkind, a) ->
- d_fkind () fkind
- ++ self#pAttrs () a
- ++ text " "
- ++ name
- | TComp (comp, a) -> (* A reference to a struct *)
- let su = if comp.cstruct then "struct" else "union" in
- text (su ^ " " ^ comp.cname ^ " ")
- ++ self#pAttrs () a
- ++ name
-
- | TEnum (enum, a) ->
- text ("enum " ^ enum.ename ^ " ")
- ++ self#pAttrs () a
- ++ name
- | TPtr (bt, a) ->
- (* Parenthesize the ( * attr name) if a pointer to a function or an
- * array. However, on MSVC the __stdcall modifier must appear right
- * before the pointer constructor "(__stdcall *f)". We push them into
- * the parenthesis. *)
- let (paren: doc option), (bt': typ) =
- match bt with
- TFun(rt, args, isva, fa) when !msvcMode ->
- let an, af', at = partitionAttributes ~default:AttrType fa in
- (* We take the af' and we put them into the parentheses *)
- Some (text "(" ++ printAttributes af'),
- TFun(rt, args, isva, addAttributes an at)
- | TFun _ | TArray _ -> Some (text "("), bt
- | _ -> None, bt
- in
- let name' = text "*" ++ printAttributes a ++ name in
- let name'' = (* Put the parenthesis *)
- match paren with
- Some p -> p ++ name' ++ text ")"
- | _ -> name'
- in
- self#pType
- (Some name'')
- ()
- bt'
- | TArray (elemt, lo, a) ->
- (* ignore the const attribute for arrays *)
- let a' = dropAttributes [ "const" ] a in
- let name' =
- if a' == [] then name else
- if nameOpt == None then printAttributes a' else
- text "(" ++ printAttributes a' ++ name ++ text ")"
- in
- self#pType
- (Some (name'
- ++ text "["
- ++ (match lo with None -> nil | Some e -> self#pExp () e)
- ++ text "]"))
- ()
- elemt
-
- | TFun (restyp, args, isvararg, a) ->
- let name' =
- if a == [] then name else
- if nameOpt == None then printAttributes a else
- text "(" ++ printAttributes a ++ name ++ text ")"
- in
- self#pType
- (Some
- (name'
- ++ text "("
- ++ (align
- ++
- (if args = Some [] && isvararg then
- text "..."
- else
- (if args = None then nil
- else if args = Some [] then text "void"
- else
- let pArg (aname, atype, aattr) =
- let stom, rest = separateStorageModifiers aattr in
- (* First the storage modifiers *)
- (self#pAttrs () stom)
- ++ (self#pType (Some (text aname)) () atype)
- ++ text " "
- ++ self#pAttrs () rest
- in
- (docList ~sep:(chr ',' ++ break) pArg) ()
- (argsToList args))
- ++ (if isvararg then break ++ text ", ..." else nil))
- ++ unalign)
- ++ text ")"))
- ()
- restyp
- | TNamed (t, a) ->
- text t.tname ++ self#pAttrs () a ++ text " " ++ name
- | TBuiltin_va_list a ->
- text "__builtin_va_list"
- ++ self#pAttrs () a
- ++ text " "
- ++ name
- (**** PRINTING ATTRIBUTES *********)
- method pAttrs () (a: attributes) =
- self#pAttrsGen false a
- (* Print one attribute. Return also an indication whether this attribute
- * should be printed inside the __attribute__ list *)
- method pAttr (Attr(an, args): attribute) : doc * bool =
- (* Recognize and take care of some known cases *)
- match an, args with
- "const", [] -> text "const", false
- (* Put the aconst inside the attribute list *)
- | "aconst", [] when not !msvcMode -> text "__const__", true
- | "thread", [] when not !msvcMode -> text "__thread", false
- (*
- | "used", [] when not !msvcMode -> text "__attribute_used__", false
- *)
- | "volatile", [] -> text "volatile", false
- | "restrict", [] -> text "__restrict", false
- | "missingproto", [] -> text "/* missing proto */", false
- | "cdecl", [] when !msvcMode -> text "__cdecl", false
- | "stdcall", [] when !msvcMode -> text "__stdcall", false
- | "fastcall", [] when !msvcMode -> text "__fastcall", false
- | "declspec", args when !msvcMode ->
- text "__declspec("
- ++ docList (self#pAttrParam ()) () args
- ++ text ")", false
- | "w64", [] when !msvcMode -> text "__w64", false
- | "asm", args ->
- text "__asm__("
- ++ docList (self#pAttrParam ()) () args
- ++ text ")", false
- (* we suppress printing mode(__si__) because it triggers an *)
- (* internal compiler error in all current gcc versions *)
- (* sm: I've now encountered a problem with mode(__hi__)... *)
- (* I don't know what's going on, but let's try disabling all "mode"..*)
- | "mode", [ACons(tag,[])] ->
- text "/* mode(" ++ text tag ++ text ") */", false
- (* sm: also suppress "format" because we seem to print it in *)
- (* a way gcc does not like *)
- | "format", _ -> text "/* format attribute */", false
- (* sm: here's another one I don't want to see gcc warnings about.. *)
- | "mayPointToStack", _ when not !print_CIL_Input
- (* [matth: may be inside another comment.]
- -> text "/*mayPointToStack*/", false
- *)
- -> text "", false
- | "arraylen", [a] ->
- (* text "/*[" ++ self#pAttrParam () a ++ text "]*/" *) nil, false
- | _ -> (* This is the dafault case *)
- (* Add underscores to the name *)
- let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in
- if args = [] then
- text an', true
- else
- text (an' ^ "(")
- ++ (docList (self#pAttrParam ()) () args)
- ++ text ")",
- true
- method private pAttrPrec (contextprec: int) () (a: attrparam) =
- let thisLevel = getParenthLevelAttrParam a in
- let needParens =
- if thisLevel >= contextprec then
- true
- else if contextprec == bitwiseLevel then
- (* quiet down some GCC warnings *)
- thisLevel == additiveLevel || thisLevel == comparativeLevel
- else
- false
- in
- if needParens then
- chr '(' ++ self#pAttrParam () a ++ chr ')'
- else
- self#pAttrParam () a
- method pAttrParam () a =
- let level = getParenthLevelAttrParam a in
- match a with
- | AInt n -> num n
- | AStr s -> text ("\"" ^ escape_string s ^ "\"")
- | ACons(s, []) -> text s
- | ACons(s,al) ->
- text (s ^ "(")
- ++ (docList (self#pAttrParam ()) () al)
- ++ text ")"
- | ASizeOfE a -> text "sizeof(" ++ self#pAttrParam () a ++ text ")"
- | ASizeOf t -> text "sizeof(" ++ self#pType None () t ++ text ")"
- | ASizeOfS ts -> text "sizeof(<typsig>)"
- | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")"
- | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")"
- | AAlignOfS ts -> text "__alignof__(<typsig>)"
- | AUnOp(u,a1) ->
- (d_unop () u) ++ chr ' ' ++ (self#pAttrPrec level () a1)
- | ABinOp(b,a1,a2) ->
- align
- ++ text "("
- ++ (self#pAttrPrec level () a1)
- ++ text ") "
- ++ (d_binop () b)
- ++ break
- ++ text " (" ++ (self#pAttrPrec level () a2) ++ text ") "
- ++ unalign
- | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s)
- | AStar a1 ->
- text "(*" ++ (self#pAttrPrec derefStarLevel () a1) ++ text ")"
- | AAddrOf a1 -> text "& " ++ (self#pAttrPrec addrOfLevel () a1)
- | AIndex (a1, a2) -> self#pAttrParam () a1 ++ text "[" ++
- self#pAttrParam () a2 ++ text "]"
- | AQuestion (a1, a2, a3) ->
- self#pAttrParam () a1 ++ text " ? " ++
- self#pAttrParam () a2 ++ text " : " ++
- self#pAttrParam () a3
-
- (* A general way of printing lists of attributes *)
- method private pAttrsGen (block: bool) (a: attributes) =
- (* Scan all the attributes and separate those that must be printed inside
- * the __attribute__ list *)
- let rec loop (in__attr__: doc list) = function
- [] -> begin
- match in__attr__ with
- [] -> nil
- | _ :: _->
- (* sm: added 'forgcc' calls to not comment things out
- * if CIL is the consumer; this is to address a case
- * Daniel ran into where blockattribute(nobox) was being
- * dropped by the merger
- *)
- (if block then
- text (" " ^ (forgcc "/*") ^ " __blockattribute__(")
- else
- text "__attribute__((")
- ++ (docList ~sep:(chr ',' ++ break)
- (fun a -> a)) () in__attr__
- ++ text ")"
- ++ (if block then text (forgcc "*/") else text ")")
- end
- | x :: rest ->
- let dx, ina = self#pAttr x in
- if ina then
- loop (dx :: in__attr__) rest
- else if dx = nil then
- loop in__attr__ rest
- else
- dx ++ text " " ++ loop in__attr__ rest
- in
- let res = loop [] a in
- if res = nil then
- res
- else
- text " " ++ res ++ text " "
- end (* class defaultCilPrinterClass *)
- let defaultCilPrinter = new defaultCilPrinterClass
- (* Top-level printing functions *)
- let printType (pp: cilPrinter) () (t: typ) : doc =
- pp#pType None () t
-
- let printExp (pp: cilPrinter) () (e: exp) : doc =
- pp#pExp () e
- let printLval (pp: cilPrinter) () (lv: lval) : doc =
- pp#pLval () lv
- let printGlobal (pp: cilPrinter) () (g: global) : doc =
- pp#pGlobal () g
- let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit =
- pp#dGlobal out g
- let printAttr (pp: cilPrinter) () (a: attribute) : doc =
- let ad, _ = pp#pAttr a in ad
- let printAttrs (pp: cilPrinter) () (a: attributes) : doc =
- pp#pAttrs () a
- let printInstr (pp: cilPrinter) () (i: instr) : doc =
- pp#pInstr () i
- let printStmt (pp: cilPrinter) () (s: stmt) : doc =
- pp#pStmt () s
- let printBlock (pp: cilPrinter) () (b: block) : doc =
- (* We must add the alignment ourselves, beucase pBlock will pop it *)
- align ++ pp#pBlock () b
- let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit =
- pp#dStmt out ind s
- let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit =
- pp#dBlock out ind b
- let printInit (pp: cilPrinter) () (i: init) : doc =
- pp#pInit () i
- let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit =
- pp#dInit out ind i
- (* Now define some short cuts *)
- let d_exp () e = printExp defaultCilPrinter () e
- let _ = pd_exp := d_exp
- let d_lval () lv = printLval defaultCilPrinter () lv
- let d_offset base () off = defaultCilPrinter#pOffset base off
- let d_init () i = printInit defaultCilPrinter () i
- let d_type () t = printType defaultCilPrinter () t
- let _ = pd_type := d_type
- let d_global () g = printGlobal defaultCilPrinter () g
- let d_attrlist () a = printAttrs defaultCilPrinter () a
- let d_attr () a = printAttr defaultCilPrinter () a
- let _ = pd_attr := d_attr
- let d_attrparam () e = defaultCilPrinter#pAttrParam () e
- let d_label () l = defaultCilPrinter#pLabel () l
- let d_stmt () s = printStmt defaultCilPrinter () s
- let d_block () b = printBlock defaultCilPrinter () b
- let d_instr () i = printInstr defaultCilPrinter () i
- let d_shortglobal () = function
- GPragma (Attr(an, _), _) -> dprintf "#pragma %s" an
- | GType (ti, _) -> dprintf "typedef %s" ti.tname
- | GVarDecl (vi, _) -> dprintf "declaration of %s" vi.vname
- | GVar (vi, _, _) -> dprintf "definition of %s" vi.vname
- | GCompTag(ci,_) -> dprintf "definition of %s" (compFullName ci)
- | GCompTagDecl(ci,_) -> dprintf "declaration of %s" (compFullName ci)
- | GEnumTag(ei,_) -> dprintf "definition of enum %s" ei.ename
- | GEnumTagDecl(ei,_) -> dprintf "declaration of enum %s" ei.ename
- | GFun(fd, _) -> dprintf "definition of %s" fd.svar.vname
- | GText _ -> text "GText"
- | GAsm _ -> text "GAsm"
- (* sm: given an ordinary CIL object printer, yield one which
- * behaves the same, except it never prints #line directives
- * (this is useful for debugging printfs) *)
- let dn_obj (func: unit -> 'a -> doc) : (unit -> 'a -> doc) =
- begin
- (* construct the closure to return *)
- let theFunc () (obj:'a) : doc =
- begin
- let prevStyle = !lineDirectiveStyle in
- lineDirectiveStyle := None;
- let ret = (func () obj) in (* call underlying printer *)
- lineDirectiveStyle := prevStyle;
- ret
- end in
- theFunc
- end
- (* now define shortcuts for the non-location-printing versions,
- * with the naming prefix "dn_" *)
- let dn_exp = (dn_obj d_exp)
- let dn_lval = (dn_obj d_lval)
- (* dn_offset is missing because it has a different interface *)
- let dn_init = (dn_obj d_init)
- let dn_type = (dn_obj d_type)
- let dn_global = (dn_obj d_global)
- let dn_attrlist = (dn_obj d_attrlist)
- let dn_attr = (dn_obj d_attr)
- let dn_attrparam = (dn_obj d_attrparam)
- let dn_stmt = (dn_obj d_stmt)
- let dn_instr = (dn_obj d_instr)
- (* Now define a cilPlainPrinter *)
- class plainCilPrinterClass =
- (* We keep track of the composite types that we have done to avoid
- * recursion *)
- let donecomps : (int, unit) H.t = H.create 13 in
- object (self)
- inherit defaultCilPrinterClass as super
-
- (*** PLAIN TYPES ***)
- method pType (dn: doc option) () (t: typ) =
- match dn with
- None -> self#pOnlyType () t
- | Some d -> d ++ text " : " ++ self#pOnlyType () t
- method private pOnlyType () = function
- TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a
- | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])"
- d_ikind ikind self#pAttrs a
- | TFloat(fkind, a) ->
- dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a
- | TNamed (t, a) ->
- dprintf "TNamed(@[%s,@?%a,@?%a@])"
- t.tname self#pOnlyType t.ttype self#pAttrs a
- | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a
- | TArray(t,l,a) ->
- let dl = match l with
- None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in
- dprintf "TArray(@[%a,@?%a,@?%a@])"
- self#pOnlyType t insert dl self#pAttrs a
- | TEnum(enum,a) -> dprintf "Enum(%s,@[%a@])" enum.ename self#pAttrs a
- | TFun(tr,args,isva,a) ->
- dprintf "TFun(@[%a,@?%a%s,@?%a@])"
- self#pOnlyType tr
- insert
- (if args = None then text "None"
- else (docList ~sep:(chr ',' ++ break)
- (fun (an,at,aa) ->
- dprintf "%s: %a" an self#pOnlyType at))
- ()
- (argsToList args))
- (if isva then "..." else "") self#pAttrs a
- | TComp (comp, a) ->
- if H.mem donecomps comp.ckey then
- dprintf "TCompLoop(%s %s, _, %a)"
- (if comp.cstruct then "struct" else "union") comp.cname
- self#pAttrs comp.cattr
- else begin
- H.add donecomps comp.ckey (); (* Add it before we do the fields *)
- dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])"
- (if comp.cstruct then "struct" else "union") comp.cname
- (docList ~sep:(chr ',' ++ break)
- (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype))
- comp.cfields
- self#pAttrs comp.cattr
- self#pAttrs a
- end
- | TBuiltin_va_list a ->
- dprintf "TBuiltin_va_list(%a)" self#pAttrs a
-
- (* Some plain pretty-printers. Unlike the above these expose all the
- * details of the internal representation *)
- method pExp () = function
- Const(c) ->
- let d_plainconst () c =
- match c with
- CInt64(i, ik, so) ->
- let fmt = if isSigned ik then "%d" else "%x" in
- dprintf "Int64(%s,%a,%s)"
- (Int64.format fmt i)
- d_ikind ik
- (match so with Some s -> s | _ -> "None")
- | CStr(s) ->
- text ("CStr(\"" ^ escape_string s ^ "\")")
- | CWStr(s) ->
- dprintf "CWStr(%a)" d_const c
-
- | CChr(c) -> text ("CChr('" ^ escape_char c ^ "')")
- | CReal(f, fk, so) ->
- dprintf "CReal(%f, %a, %s)"
- f
- d_fkind fk
- (match so with Some s -> s | _ -> "None")
- | CEnum(_, s, _) -> text s
- in
- text "Const(" ++ d_plainconst () c ++ text ")"
- | Lval(lv) ->
- text "Lval("
- ++ (align
- ++ self#pLval () lv
- ++ unalign)
- ++ text ")"
-
- | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e
- | UnOp(u,e1,_) ->
- dprintf "UnOp(@[%a,@?%a@])"
- d_unop u self#pExp e1
-
- | BinOp(b,e1,e2,_) ->
- let d_plainbinop () b =
- match b with
- PlusA -> text "PlusA"
- | PlusPI -> text "PlusPI"
- | IndexPI -> text "IndexPI"
- | MinusA -> text "MinusA"
- | MinusPP -> text "MinusPP"
- | MinusPI -> text "MinusPI"
- | _ -> d_binop () b
- in
- dprintf "%a(@[%a,@?%a@])" d_plainbinop b
- self#pExp e1 self#pExp e2
- | Question(e1,e2,e3,_) ->
- dprintf "Question(@[%a,@?%a,@?%a@])"
- self#pExp e1 self#pExp e2 self#pExp e3
- | SizeOf (t) ->
- text "sizeof(" ++ self#pType None () t ++ chr ')'
- | SizeOfE (e) ->
- text "sizeofE(" ++ self#pExp () e ++ chr ')'
- | SizeOfStr (s) ->
- text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')'
- | AlignOf (t) ->
- text "__alignof__(" ++ self#pType None () t ++ chr ')'
- | AlignOfE (e) ->
- text "__alignof__(" ++ self#pExp () e ++ chr ')'
- | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv
- | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv
- | AddrOfLabel (sref) -> dprintf "AddrOfLabel(%a)" self#pStmt !sref
- method private d_plainoffset () = function
- NoOffset -> text "NoOffset"
- | Field(fi,o) ->
- dprintf "Field(@[%s:%a,@?%a@])"
- fi.fname self#pOnlyType fi.ftype self#d_plainoffset o
- | Index(e, o) ->
- dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
- method pInit () = function
- SingleInit e -> dprintf "SI(%a)" d_exp e
- | CompoundInit (t, initl) ->
- let d_plainoneinit (o, i) =
- self#d_plainoffset () o ++ text " = " ++ self#pInit () i
- in
- dprintf "CI(@[%a,@?%a@])" self#pOnlyType t
- (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl
- (*
- | ArrayInit (t, len, initl) ->
- let idx = ref (- 1) in
- let d_plainoneinit i =
- incr idx;
- text "[" ++ num !idx ++ text "] = " ++ self#pInit () i
- in
- dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len
- (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl
- *)
- method pLval () (lv: lval) =
- match lv with
- | Var vi, o -> dprintf "Var(@[%s,@?%a@])" vi.vname self#d_plainoffset o
- | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
- end
- let plainCilPrinter = new plainCilPrinterClass
- (* And now some shortcuts *)
- let d_plainexp () e = plainCilPrinter#pExp () e
- let d_plaintype () t = plainCilPrinter#pType None () t
- let d_plaininit () i = plainCilPrinter#pInit () i
- let d_plainlval () l = plainCilPrinter#pLval () l
- class type descriptiveCilPrinter = object
- inherit cilPrinter
- method startTemps: unit -> unit
- method stopTemps: unit -> unit
- method pTemps: unit -> Pretty.doc
- end
- class descriptiveCilPrinterClass (enable: bool) : descriptiveCilPrinter =
- object (self)
- (** Like defaultCilPrinterClass, but instead of temporary variable
- names it prints the description that was provided when the temp was
- created. This is usually better for messages that are printed for end
- users, although you may want the temporary names for debugging.
-
- The boolean here enables descriptive printing. Usually use true
- here, but you can set enable to false to make this class behave
- like defaultCilPrinterClass. This allows subclasses to turn the
- feature off. *)
- inherit defaultCilPrinterClass as super
- val mutable temps: (varinfo * string * doc) list = []
- val mutable useTemps: bool = false
- method startTemps () : unit =
- temps <- [];
- useTemps <- true
- method stopTemps () : unit =
- temps <- [];
- useTemps <- false
- method pTemps () : doc =
- if temps = [] then
- nil
- else
- text "\nWhere:\n " ++
- docList ~sep:(text "\n ")
- (fun (_, s, d) -> dprintf "%s = %a" s insert d) ()
- (List.rev temps)
- method private pVarDescriptive (vi: varinfo) : doc =
- if vi.vdescr <> nil then begin
- if vi.vdescrpure || not useTemps then
- vi.vdescr
- else begin
- try
- let _, name, _ = List.find (fun (vi', _, _) -> vi == vi') temps in
- text name
- with Not_found ->
- let name = "tmp" ^ string_of_int (List.length temps) in
- temps <- (vi, name, vi.vdescr) :: temps;
- text name
- end
- end else
- super#pVar vi
- (* Only substitute temp vars that appear in expressions.
- (Other occurrences of lvalues are the left-hand sides of assignments,
- but we shouldn't substitute there since "foo(a,b) = foo(a,b)"
- would make no sense to the user.) *)
- method pExp () (e:exp) : doc =
- if enable then
- match e with
- Lval (Var vi, o)
- | StartOf (Var vi, o) ->
- self#pOffset (self#pVarDescriptive vi) o
- | AddrOf (Var vi, o) ->
- (* No parens needed, since offsets have higher precedence than & *)
- text "& " ++ self#pOffset (self#pVarDescriptive vi) o
- | _ -> super#pExp () e
- else
- super#pExp () e
- end
- let descriptiveCilPrinter: descriptiveCilPrinter =
- ((new descriptiveCilPrinterClass true) :> descriptiveCilPrinter)
- let dd_exp = descriptiveCilPrinter#pExp
- let dd_lval = descriptiveCilPrinter#pLval
- (* zra: this allows pretty printers not in cil.ml to
- be exposed to cilmain.ml *)
- let printerForMaincil = ref defaultCilPrinter
- let rec d_typsig () = function
- TSArray (ts, eo, al) ->
- dprintf "TSArray(@[%a,@?%a,@?%a@])"
- d_typsig ts
- insert (text (match eo with None -> "None"
- | Some e -> "Some " ^ Int64.to_string e))
- d_attrlist al
- | TSPtr (ts, al) ->
- dprintf "TSPtr(@[%a,@?%a@])"
- d_typsig ts d_attrlist al
- | TSComp (iss, name, al) ->
- dprintf "TSComp(@[%s %s,@?%a@])"
- (if iss then "struct" else "union") name
- d_attrlist al
- | TSFun (rt, args, isva, al) ->
- dprintf "TSFun(@[%a,@?%a,%B,@?%a@])"
- d_typsig rt
- insert
- (match args with
- | None -> text "None"
- | Some args ->
- docList ~sep:(chr ',' ++ break) (d_typsig ()) () args)
- isva
- d_attrlist al
- | TSEnum (n, al) ->
- dprintf "TSEnum(@[%s,@?%a@])"
- n d_attrlist al
- | TSBase t -> dprintf "TSBase(%a)" d_type t
- let newVID () =
- let t = !nextGlobalVID in
- incr nextGlobalVID;
- t
- (* Make a varinfo. Used mostly as a helper function below *)
- let makeVarinfo global name ?init typ =
- (* Strip const from type for locals *)
- let vi =
- { vname = name;
- vid = newVID ();
- vglob = global;
- vtype = if global then typ else typeRemoveAttributes ["const"] typ;
- vdecl = lu;
- vinit = {init=init};
- vinline = false;
- vattr = [];
- vstorage = NoStorage;
- vaddrof = false;
- vreferenced = false;
- vdescr = nil;
- vdescrpure = true;
- } in
- vi
-
- let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
- let vi' = {vi with vname = newname; vid = newVID () } in
- vi'
- let makeLocal fdec name typ init = (* a helper function *)
- fdec.smaxid <- 1 + fdec.smaxid;
- let vi = makeVarinfo false name ?init:init typ in
- vi
-
- (* Make a local variable and add it to a function *)
- let makeLocalVar fdec ?(insert = true) name ?init typ =
- let vi = makeLocal fdec name typ init in
- if insert then fdec.slocals <- fdec.slocals @ [vi];
- vi
- let makeTempVar fdec ?(insert = true) ?(name = "__cil_tmp")
- ?(descr = nil) ?(descrpure = true) typ : varinfo =
- let rec findUniqueName () : string=
- let n = name ^ (string_of_int (1 + fdec.smaxid)) in
- (* Is this check a performance problem? We could bring the old
- unchecked makeTempVar back as a separate function that assumes
- the prefix name does not occur in the original program. *)
- if (List.exists (fun vi -> vi.vname = n) fdec.slocals)
- || (List.exists (fun vi -> vi.vname = n) fdec.sformals) then begin
- fdec.smaxid <- 1 + fdec.smaxid;
- findUniqueName ()
- end else
- n
- in
- let name = findUniqueName () in
- let vi = makeLocalVar fdec ~insert name typ in
- vi.vdescr <- descr;
- vi.vdescrpure <- descrpure;
- vi
-
- (* Set the formals and re-create the function name based on the information*)
- let setFormals (f: fundec) (forms: varinfo list) =
- f.sformals <- forms; (* Set the formals *)
- match unrollType f.svar.vtype with
- TFun(rt, _, isva, fa) ->
- f.svar.vtype <-
- TFun(rt,
- Some (Util.list_map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
- isva, fa)
- | _ -> E.s (E.bug "Set formals. %s does not have function type\n"
- f.svar.vname)
-
- (* Set the types of arguments and results as given by the function type
- * passed as the second argument *)
- let setFunctionType (f: fundec) (t: typ) =
- match unrollType t with
- TFun (rt, Some args, va, a) ->
- if List.length f.sformals <> List.length args then
- E.s (E.bug "setFunctionType: number of arguments differs from the number of formals");
- (* Change the function type. *)
- f.svar.vtype <- t;
- (* Change the sformals and we know that indirectly we'll change the
- * function type *)
- List.iter2
- (fun (an,at,aa) f ->
- f.vtype <- at; f.vattr <- aa)
- args f.sformals
- | _ -> E.s (E.bug "setFunctionType: not a function type")
-
- (* Set the types of arguments and results as given by the function type
- * passed as the second argument *)
- let setFunctionTypeMakeFormals (f: fundec) (t: typ) =
- match unrollType t with
- TFun (rt, Some args, va, a) ->
- if f.sformals <> [] then
- E.s (E.warn "setFunctionTypMakeFormals called on function %s with some formals already"
- f.svar.vname);
- (* Change the function type. *)
- f.svar.vtype <- t;
- f.sformals <- [];
-
- f.sformals <- Util.list_map (fun (n,t,a) -> makeLocal f n t None) args;
- setFunctionType f t
- | _ -> E.s (E.bug "setFunctionTypeMakeFormals: not a function type: %a"
- d_type t)
-
- let setMaxId (f: fundec) =
- f.smaxid <- List.length f.sformals + List.length f.slocals
-
- (* Make a formal variable for a function. Insert it in both the sformals
- * and the type of the function. You can optionally specify where to insert
- * this one. If where = "^" then it is inserted first. If where = "$" then
- * it is inserted last. Otherwise where must be the name of a formal after
- * which to insert this. By default it is inserted at the end. *)
- let makeFormalVar fdec ?(where = "$") name typ : varinfo =
- (* Search for the insertion place *)
- let thenewone = ref fdec.svar in (* Just a placeholder *)
- let makeit () : varinfo =
- let vi = makeLocal fdec name typ None in
- thenewone := vi;
- vi
- in
- let rec loopFormals = function
- [] ->
- if where = "$" then [makeit ()]
- else E.s (E.error "makeFormalVar: cannot find insert-after formal %s"
- where)
- | f :: rest when f.vname = where -> f :: makeit () :: rest
- | f :: rest -> f :: loopFormals rest
- in
- let newformals =
- if where = "^" then makeit () :: fdec.sformals else
- loopFormals fdec.sformals in
- setFormals fdec newformals;
- !thenewone
- (* Make a global variable. Your responsibility to make sure that the name
- * is unique *)
- let makeGlobalVar name typ =
- let vi = makeVarinfo true name typ in
- vi
- (* Make an empty function *)
- let emptyFunction name =
- { svar = makeGlobalVar name (TFun(voidType, Some [], false,[]));
- smaxid = 0;
- slocals = [];
- sformals = [];
- sbody = mkBlock [];
- smaxstmtid = None;
- sallstmts = [];
- }
- (* A dummy function declaration handy for initialization *)
- let dummyFunDec = emptyFunction "@dummy"
- let dummyFile =
- { globals = [];
- fileName = "<dummy>";
- globinit = None;
- globinitcalled = false;}
- (***** Load and store files as unmarshalled Ocaml binary data. ****)
- type savedFile =
- { savedFile: file;
- savedNextVID: int;
- savedNextCompinfoKey: int}
- let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) =
- let save = {savedFile = cil_file;
- savedNextVID = !nextGlobalVID;
- savedNextCompinfoKey = !nextCompinfoKey} in
- Marshal.to_channel outchan save []
- let saveBinaryFile (cil_file : file) (filename : string) =
- let outchan = open_out_bin filename in
- saveBinaryFileChannel cil_file outchan;
- close_out outchan
- (** Read a {!Cil.file} in binary form from the filesystem. The first
- * argument is the name of a file previously created by
- * {!Cil.saveBinaryFile}. Because this also reads some global state,
- * this should be called before any other CIL code is parsed or generated. *)
- let loadBinaryFile (filename : string) : file =
- let inchan = open_in_bin filename in
- let loaded : savedFile = (Marshal.from_channel inchan : savedFile) in
- close_in inchan ;
- (* nextGlobalVID = 11 because CIL initialises many dummy variables *)
- if !nextGlobalVID != 11 || !nextCompinfoKey != 1 then begin
- (* In this case, we should change all of the varinfo and compinfo
- keys in loaded.savedFile to prevent conflicts. But since that hasn't
- been implemented yet, just print a warning. If you do implement this,
- please send it to the CIL maintainers. *)
- ignore (E.warn "You are possibly loading a binary file after another file has been loaded. This isn't currently supported, so varinfo and compinfo id numbers may conflict.")
- end;
- nextGlobalVID := max loaded.savedNextVID !nextGlobalVID;
- nextCompinfoKey := max loaded.savedNextCompinfoKey !nextCompinfoKey;
- loaded.savedFile
- (* Take the name of a file and make a valid symbol name out of it. There are
- * a few characters that are not valid in symbols *)
- let makeValidSymbolName (s: string) =
- let s = String.copy s in (* So that we can update in place *)
- let l = String.length s in
- for i = 0 to l - 1 do
- let c = String.get s i in
- let isinvalid =
- match c with
- '-' | '.' -> true
- | _ -> false
- in
- if isinvalid then
- String.set s i '_';
- done;
- s
- let rec addOffset (toadd: offset) (off: offset) : offset =
- match off with
- NoOffset -> toadd
- | Field(fid', offset) -> Field(fid', addOffset toadd offset)
- | Index(e, offset) -> Index(e, addOffset toadd offset)
- (* Add an offset at the end of an lv *)
- let addOffsetLval toadd (b, off) : lval =
- b, addOffset toadd off
- let rec removeOffset (off: offset) : offset * offset =
- match off with
- NoOffset -> NoOffset, NoOffset
- | Field(f, NoOffset) -> NoOffset, off
- | Index(i, NoOffset) -> NoOffset, off
- | Field(f, restoff) ->
- let off', last = removeOffset restoff in
- Field(f, off'), last
- | Index(i, restoff) ->
- let off', last = removeOffset restoff in
- Index(i, off'), last
- let removeOffsetLval ((b, off): lval) : lval * offset =
- let off', last = removeOffset off in
- (b, off'), last
- (*** Define the visiting engine ****)
- (* visit all the nodes in a Cil expression *)
- let doVisit (vis: cilVisitor)
- (action: 'a visitAction)
- (children: cilVisitor -> 'a -> 'a)
- (node: 'a) : 'a =
- match action with
- SkipChildren -> node
- | ChangeTo node' -> node'
- | DoChildren -> children vis node
- | ChangeDoChildrenPost(node', f) -> f (children vis node')
- (* mapNoCopy is like map but avoid copying the list if the function does not
- * change the elements. *)
- let mapNoCopy (f: 'a -> 'a) l =
- let rec aux acc changed = function
- [] -> if changed then List.rev acc else l
- | i :: resti ->
- let i' = f i in
- aux (i' :: acc) (changed || i != i') resti
- in aux [] false l
- let rec mapNoCopyList (f: 'a -> 'a list) l =
- let rec aux acc changed = function
- [] -> if changed then List.rev acc else l
- | i :: resti ->
- let il' = f i in
- let has_changed =
- match il' with
- [i'] when i' == i -> false
- | _ -> true in
- aux (List.rev_append il' acc) (changed || has_changed) resti
- in aux [] false l
- (* A visitor for lists *)
- let doVisitList (vis: cilVisitor)
- (action: 'a list visitAction)
- (children: cilVisitor -> 'a -> 'a)
- (node: 'a) : 'a list =
- match action with
- SkipChildren -> [node]
- | ChangeTo nodes' -> nodes'
- | DoChildren -> [children vis node]
- | ChangeDoChildrenPost(nodes', f) ->
- f (mapNoCopy (fun n -> children vis n) nodes')
-
- let debugVisit = false
- let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp =
- doVisit vis (vis#vexpr e) childrenExp e
- and childrenExp (vis: cilVisitor) (e: exp) : exp =
- let vExp e = visitCilExpr vis e in
- let vTyp t = visitCilType vis t in
- let vLval lv = visitCilLval vis lv in
- match e with
- | Const (CEnum(v, s, ei)) ->
- let v' = vExp v in
- if v' != v then Const (CEnum(v', s, ei)) else e
- | Const _ -> e
- | SizeOf t ->
- let t'= vTyp t in
- if t' != t then SizeOf t' else e
- | SizeOfE e1 ->
- let e1' = vExp e1 in
- if e1' != e1 then SizeOfE e1' else e
- | SizeOfStr s -> e
- | AlignOf t ->
- let t' = vTyp t in
- if t' != t then AlignOf t' else e
- | AlignOfE e1 ->
- let e1' = vExp e1 in
- if e1' != e1 then AlignOfE e1' else e
- | Lval lv ->
- let lv' = vLval lv in
- if lv' != lv then Lval lv' else e
- | UnOp (uo, e1, t) ->
- let e1' = vExp e1 in let t' = vTyp t in
- if e1' != e1 || t' != t then UnOp(uo, e1', t') else e
- | BinOp (bo, e1, e2, t) ->
- let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in
- if e1' != e1 || e2' != e2 || t' != t then BinOp(bo, e1',e2',t') else e
- | Question (e1, e2, e3, t) ->
- let e1' = vExp e1 in let e2' = vExp e2 in let e3' = vExp e3 in let t' = vTyp t in
- if e1' != e1 || e2' != e2 || e3' != e3 || t' != t then Question(e1',e2',e3',t') else e
- | CastE (t, e1) ->
- let t' = vTyp t in let e1' = vExp e1 in
- if t' != t || e1' != e1 then CastE(t', e1') else e
- | AddrOf lv ->
- let lv' = vLval lv in
- if lv' != lv then AddrOf lv' else e
- | AddrOfLabel _ -> e
- | StartOf lv ->
- let lv' = vLval lv in
- if lv' != lv then StartOf lv' else e
- and visitCilInit (vis: cilVisitor) (forglob: varinfo)
- (atoff: offset) (i: init) : init =
- let rec childrenInit (vis: cilVisitor) (i: init) : init =
- let fExp e = visitCilExpr vis e in
- let fTyp t = visitCilType vis t in
- match i with
- | SingleInit e ->
- let e' = fExp e in
- if e' != e then SingleInit e' else i
- | CompoundInit (t, initl) ->
- let t' = fTyp t in
- (* Collect the new initializer list, in reverse. We prefer two
- * traversals to ensure tail-recursion. *)
- let newinitl : (offset * init) list ref = ref [] in
- (* Keep track whether the list has changed *)
- let hasChanged = ref false in
- let doOneInit ((o, i) as oi) =
- let o' = visitCilInitOffset vis o in (* use initializer version *)
- let i' = visitCilInit vis forglob (addOffset o' atoff) i in
- let newio =
- if o' != o || i' != i then
- begin hasChanged := true; (o', i') end else oi
- in
- newinitl := newio :: !newinitl
- in
- List.iter doOneInit initl;
- let initl' = if !hasChanged then List.rev !newinitl else initl in
- if t' != t || initl' != initl then CompoundInit (t', initl') else i
- in
- doVisit vis (vis#vinit forglob atoff i) childrenInit i
-
- and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
- doVisit vis (vis#vlval lv) childrenLval lv
- and childrenLval (vis: cilVisitor) (lv: lval) : lval =
- (* and visit its subexpressions *)
- let vExp e = visitCilExpr vis e in
- let vOff off = visitCilOffset vis off in
- match lv with
- Var v, off ->
- let v' = doVisit vis (vis#vvrbl v) (fun _ x -> x) v in
- let off' = vOff off in
- if v' != v || off' != off then Var v', off' else lv
- | Mem e, off ->
- let e' = vExp e in
- let off' = vOff off in
- if e' != e || off' != off then Mem e', off' else lv
- and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
- doVisit vis (vis#voffs off) childrenOffset off
- and childrenOffset (vis: cilVisitor) (off: offset) : offset =
- let vOff off = visitCilOffset vis off in
- match off with
- Field (f, o) ->
- let o' = vOff o in
- if o' != o then Field (f, o') else off
- | Index (e, o) ->
- let e' = visitCilExpr vis e in
- let o' = vOff o in
- if e' != e || o' != o then Index (e', o') else off
- | NoOffset -> off
- (* sm: for offsets in initializers, the 'startvisit' will be the
- * vinitoffs method, but we can re-use the childrenOffset from
- * above since recursive offsets are visited by voffs. (this point
- * is moot according to cil.mli which claims the offsets in
- * initializers will never recursively contain offsets)
- *)
- and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
- doVisit vis (vis#vinitoffs off) childrenOffset off
- and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
- let oldloc = !currentLoc in
- currentLoc := (get_instrLoc i);
- assertEmptyQueue vis;
- let res = doVisitList vis (vis#vinst i) childrenInstr i in
- currentLoc := oldloc;
- (* See if we have accumulated some instructions *)
- vis#unqueueInstr () @ res
- and childrenInstr (vis: cilVisitor) (i: instr) : instr =
- let fExp e = visitCilExpr vis e in
- let fLval lv = visitCilLval vis lv in
- match i with
- | Set(lv,e,l) ->
- let lv' = fLval lv in let e' = fExp e in
- if lv' != lv || e' != e then Set(lv',e',l) else i
- | Call(None,f,args,l) ->
- let f' = fExp f in let args' = mapNoCopy fExp args in
- if f' != f || args' != args then Call(None,f',args',l) else i
- | Call(Some lv,fn,args,l) ->
- let lv' = fLval lv in let fn' = fExp fn in
- let args' = mapNoCopy fExp args in
- if lv' != lv || fn' != fn || args' != args
- then Call(Some lv', fn', args', l) else i
- | Asm(sl,isvol,outs,ins,clobs,l) ->
- let outs' = mapNoCopy (fun ((id,s,lv) as pair) ->
- let lv' = fLval lv in
- if lv' != lv then (id,s,lv') else pair) outs in
- let ins' = mapNoCopy (fun ((id,s,e) as pair) ->
- let e' = fExp e in
- if e' != e then (id,s,e') else pair) ins in
- if outs' != outs || ins' != ins then
- Asm(sl,isvol,outs',ins',clobs,l) else i
- (* visit all nodes in a Cil statement tree in preorder *)
- and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt =
- let oldloc = !currentLoc in
- currentLoc := (get_stmtLoc s.skind) ;
- assertEmptyQueue vis;
- let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
- let res = doVisit vis (vis#vstmt s) (childrenStmt toPrepend) s in
- (* Now see if we have saved some instructions *)
- toPrepend := !toPrepend @ vis#unqueueInstr ();
- (match !toPrepend with
- [] -> () (* Return the same statement *)
- | _ ->
- (* Make our statement contain the instructions to prepend *)
- res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend);
- mkStmt res.skind ] });
- currentLoc := oldloc;
- res
-
- and childrenStmt (toPrepend: instr list ref) : cilVisitor -> stmt -> stmt =
- (* this is a hack to avoid currying and reduce GC pressure *)
- () ; fun vis s ->
- let fExp e = (visitCilExpr vis e) in
- let fBlock b = visitCilBlock vis b in
- let fInst i = visitCilInstr vis i in
- (* Just change the statement kind *)
- let skind' =
- match s.skind with
- Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind
- | ComputedGoto (e, l) ->
- let e' = fExp e in
- if e' != e then ComputedGoto (e', l) else s.skind
- | Return (Some e, l) ->
- let e' = fExp e in
- if e' != e then Return (Some e', l) else s.skind
- | Loop (b, l, s1, s2) ->
- let b' = fBlock b in
- if b' != b then Loop (b', l, s1, s2) else s.skind
- | If(e, s1, s2, l) ->
- let e' = fExp e in
- (*if e queued any instructions, pop them here and remember them so that
- they are inserted before the If stmt, not in the then block. *)
- toPrepend := vis#unqueueInstr ();
- let s1'= fBlock s1 in let s2'= fBlock s2 in
- (* the stmts in the blocks should have cleaned up after themselves.*)
- assertEmptyQueue vis;
- if e' != e || s1' != s1 || s2' != s2 then
- If(e', s1', s2', l) else s.skind
- | Switch (e, b, stmts, l) ->
- let e' = fExp e in
- toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
- let b' = fBlock b in
- (* the stmts in b should have cleaned up after themselves.*)
- assertEmptyQueue vis;
- (* Don't do stmts, but we better not change those *)
- if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind
- | Instr il ->
- let il' = mapNoCopyList fInst il in
- if il' != il then Instr il' else s.skind
- | Block b ->
- let b' = fBlock b in
- if b' != b then Block b' else s.skind
- | TryFinally (b, h, l) ->
- let b' = fBlock b in
- let h' = fBlock h in
- if b' != b || h' != h then TryFinally(b', h', l) else s.skind
- | TryExcept (b, (il, e), h, l) ->
- let b' = fBlock b in
- assertEmptyQueue vis;
- (* visit the instructions *)
- let il' = mapNoCopyList fInst il in
- (* Visit the expression *)
- let e' = fExp e in
- let il'' =
- let more = vis#unqueueInstr () in
- if more != [] then
- il' @ more
- else
- il'
- in
- let h' = fBlock h in
- (* Now collect the instructions *)
- if b' != b || il'' != il || e' != e || h' != h then
- TryExcept(b', (il'', e'), h', l)
- else s.skind
- in
- if skind' != s.skind then s.skind <- skind';
- (* Visit the labels *)
- let labels' =
- let fLabel = function
- Case (e, l) as lb ->
- let e' = fExp e in
- if e' != e then Case (e', l) else lb
- | CaseRange (e1, e2, l) as lb ->
- let e1' = fExp e1 in
- let e2' = fExp e2 in
- if e1' != e1 || e2' != e2 then CaseRange (e1', e2', l) else lb
- | lb -> lb
- in
- mapNoCopy fLabel s.labels
- in
- if labels' != s.labels then s.labels <- labels';
- s
-
-
-
- and visitCilBlock (vis: cilVisitor) (b: block) : block =
- doVisit vis (vis#vblock b) childrenBlock b
- and childrenBlock (vis: cilVisitor) (b: block) : block =
- let fStmt s = visitCilStmt vis s in
- let stmts' = mapNoCopy fStmt b.bstmts in
- if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b
- and visitCilType (vis : cilVisitor) (t : typ) : typ =
- doVisit vis (vis#vtype t) childrenType t
- and childrenType (vis : cilVisitor) (t : typ) : typ =
- (* look for types referred to inside t's definition *)
- let fTyp t = visitCilType vis t in
- let fAttr a = visitCilAttributes vis a in
- match t with
- TPtr(t1, a) ->
- let t1' = fTyp t1 in
- let a' = fAttr a in
- if t1' != t1 || a' != a then TPtr(t1', a') else t
- | TArray(t1, None, a) ->
- let t1' = fTyp t1 in
- let a' = fAttr a in
- if t1' != t1 || a' != a then TArray(t1', None, a') else t
- | TArray(t1, Some e, a) ->
- let t1' = fTyp t1 in
- let e' = visitCilExpr vis e in
- let a' = fAttr a in
- if t1' != t1 || e' != e || a' != a then TArray(t1', Some e', a') else t
- (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
- User can iterate over cinfo.cfields manually, if desired.*)
- | TComp(cinfo, a) ->
- let a' = fAttr a in
- if a != a' then TComp(cinfo, a') else t
- | TFun(rettype, args, isva, a) ->
- let rettype' = fTyp rettype in
- (* iterate over formals, as variable declarations *)
- let argslist = argsToList args in
- let visitArg ((an,at,aa) as arg) =
- let at' = fTyp at in
- let aa' = fAttr aa in
- if at' != at || aa' != aa then (an,at',aa') else arg
- in
- let argslist' = mapNoCopy visitArg argslist in
- let a' = fAttr a in
- if rettype' != rettype || argslist' != argslist || a' != a then
- let args' = if argslist' == argslist then args else Some argslist' in
- TFun(rettype', args', isva, a') else t
- | TNamed(t1, a) -> (* Do not go into the type. Will do it at the time of
- * GType *)
- let a' = fAttr a in
- if a' != a then TNamed (t1, a') else t
- | _ -> (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list)
- don't contain nested types, but they do have attributes. *)
- let a = typeAttrs t in
- let a' = fAttr a in
- if a' != a then setTypeAttrs t a' else t
-
- (* for declarations, we visit the types inside; but for uses, *)
- (* we just visit the varinfo node *)
- and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
- doVisit vis (vis#vvdec v) childrenVarDecl v
- and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
- v.vtype <- visitCilType vis v.vtype;
- v.vattr <- visitCilAttributes vis v.vattr;
- (match v.vinit.init with
- None -> ()
- | Some i -> let i' = visitCilInit vis v NoOffset i in
- if i' != i then v.vinit.init <- Some i');
- v
- and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
- let al' =
- mapNoCopyList (fun x -> doVisitList vis (vis#vattr x) childrenAttribute x) al in
- if al' != al then
- (* Must re-sort *)
- addAttributes al' []
- else
- al
- and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
- let fAttrP a = visitCilAttrParams vis a in
- match a with
- Attr (n, args) ->
- let args' = mapNoCopy fAttrP args in
- if args' != args then Attr(n, args') else a
-
- and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
- doVisit vis (vis#vattrparam a) childrenAttrparam a
- and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
- let fTyp t = visitCilType vis t in
- let fAttrP a = visitCilAttrParams vis a in
- match aa with
- AInt _ | AStr _ -> aa
- | ACons(n, args) ->
- let args' = mapNoCopy fAttrP args in
- if args' != args then ACons(n, args') else aa
- | ASizeOf t ->
- let t' = fTyp t in
- if t' != t then ASizeOf t' else aa
- | ASizeOfE e ->
- let e' = fAttrP e in
- if e' != e then ASizeOfE e' else aa
- | AAlignOf t ->
- let t' = fTyp t in
- if t' != t then AAlignOf t' else aa
- | AAlignOfE e ->
- let e' = fAttrP e in
- if e' != e then AAlignOfE e' else aa
- | ASizeOfS _ | AAlignOfS _ ->
- ignore (warn "Visitor inside of a type signature.");
- aa
- | AUnOp (uo, e1) ->
- let e1' = fAttrP e1 in
- if e1' != e1 then AUnOp (uo, e1') else aa
- | ABinOp (bo, e1, e2) ->
- let e1' = fAttrP e1 in
- let e2' = fAttrP e2 in
- if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
- | ADot (ap, s) ->
- let ap' = fAttrP ap in
- if ap' != ap then ADot (ap', s) else aa
- | AStar ap ->
- let ap' = fAttrP ap in
- if ap' != ap then AStar ap' else aa
- | AAddrOf ap ->
- let ap' = fAttrP ap in
- if ap' != ap then AAddrOf ap' else aa
- | AIndex (e1, e2) ->
- let e1' = fAttrP e1 in
- let e2' = fAttrP e2 in
- if e1' != e1 || e2' != e2 then AIndex (e1', e2') else aa
- | AQuestion (e1, e2, e3) ->
- let e1' = fAttrP e1 in
- let e2' = fAttrP e2 in
- let e3' = fAttrP e3 in
- if e1' != e1 || e2' != e2 || e3' != e3
- then AQuestion (e1', e2', e3') else aa
-
- let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
- if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname);
- assertEmptyQueue vis;
- let f = doVisit vis (vis#vfunc f) childrenFunction f in
- let toPrepend = vis#unqueueInstr () in
- if toPrepend <> [] then
- f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts;
- f
- and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
- let visitVarDecl vd = visitCilVarDecl vis vd in
- f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
- (* visit local declarations *)
- f.slocals <- mapNoCopy visitVarDecl f.slocals;
- (* visit the formals *)
- let newformals = mapNoCopy visitVarDecl f.sformals in
- (* Make sure the type reflects the formals *)
- setFormals f newformals;
- (* Remember any new instructions that were generated while visiting
- variable declarations. *)
- let toPrepend = vis#unqueueInstr () in
- f.sbody <- visitCilBlock vis f.sbody; (* visit the body *)
- if toPrepend <> [] then
- f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts;
- f
- let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
- (*(trace "visit" (dprintf "visitCilGlobal\n"));*)
- let oldloc = !currentLoc in
- currentLoc := (get_globalLoc g) ;
- currentGlobal := g;
- let res = doVisitList vis (vis#vglob g) childrenGlobal g in
- currentLoc := oldloc;
- res
- and childrenGlobal (vis: cilVisitor) (g: global) : global =
- match g with
- | GFun (f, l) ->
- let f' = visitCilFunction vis f in
- if f' != f then GFun (f', l) else g
- | GType(t, l) ->
- t.ttype <- visitCilType vis t.ttype;
- g
- | GEnumTagDecl _ | GCompTagDecl _ -> g (* Nothing to visit *)
- | GEnumTag (enum, _) ->
- (* (trace "visit" (dprintf "visiting global enum %s\n" enum.ename)); *)
- (* Do the values and attributes of the enumerated items *)
- let itemVisit (name, exp, loc) = (name, visitCilExpr vis exp, loc) in
- enum.eitems <- mapNoCopy itemVisit enum.eitems;
- enum.eattr <- visitCilAttributes vis enum.eattr;
- g
- | GCompTag (comp, _) ->
- (* (trace "visit" (dprintf "visiting global comp %s\n" comp.cname)); *)
- (* Do the types and attirbutes of the fields *)
- let fieldVisit = fun fi ->
- fi.ftype <- visitCilType vis fi.ftype;
- fi.fattr <- visitCilAttributes vis fi.fattr
- in
- List.iter fieldVisit comp.cfields;
- comp.cattr <- visitCilAttributes vis comp.cattr;
- g
- | GVarDecl(v, l) ->
- let v' = visitCilVarDecl vis v in
- if v' != v then GVarDecl (v', l) else g
- | GVar (v, inito, l) ->
- let v' = visitCilVarDecl vis v in
- if v' != v then GVar (v', inito, l) else g
- | GPragma (a, l) -> begin
- match visitCilAttributes vis [a] with
- [a'] -> if a' != a then GPragma (a', l) else g
- | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute")
- end
- | _ -> g
- (** A visitor that does constant folding. If "machdep" is true then we do
- * machine dependent simplification (e.g., sizeof) *)
- class constFoldVisitorClass (machdep: bool) : cilVisitor = object
- inherit nopCilVisitor
-
- method vinst i =
- match i with
- (* Skip two functions to which we add Sizeof to the type arguments.
- See the comments for these above. *)
- Call(_,(Lval (Var vi,NoOffset)),_,_)
- when ((vi.vname = "__builtin_va_arg")
- || (vi.vname = "__builtin_types_compatible_p")) ->
- SkipChildren
- | _ -> DoChildren
- method vexpr (e: exp) =
- (* Do it bottom up *)
- ChangeDoChildrenPost (e, constFold machdep)
-
- end
- let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep
- (* Iterate over all globals, including the global initializer *)
- let iterGlobals (fl: file)
- (doone: global -> unit) : unit =
- let doone' g =
- currentLoc := get_globalLoc g;
- doone g
- in
- List.iter doone' fl.globals;
- (match fl.globinit with
- None -> ()
- | Some g -> doone' (GFun(g, locUnknown)))
- (* Fold over all globals, including the global initializer *)
- let foldGlobals (fl: file)
- (doone: 'a -> global -> 'a)
- (acc: 'a) : 'a =
- let doone' acc g =
- currentLoc := get_globalLoc g;
- doone acc g
- in
- let acc' = List.fold_left doone' acc fl.globals in
- (match fl.globinit with
- None -> acc'
- | Some g -> doone' acc' (GFun(g, locUnknown)))
- (** Find a function or function prototype with the given name in the file.
- * If it does not exist, create a prototype with the given type, and return
- * the new varinfo. This is useful when you need to call a libc function
- * whose prototype may or may not already exist in the file.
- *
- * Because the new prototype is added to the start of the file, you shouldn't
- * refer to any struct or union types in the function type.*)
- let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo =
- let rec search glist =
- match glist with
- GVarDecl(vi,_) :: rest | GFun ({svar = vi},_) :: rest when vi.vname = name ->
- if not (isFunctionType vi.vtype) then
- E.s (error ("findOrCreateFunc: can't create %s because another "
- ^^"global exists with that name.") name);
- vi
- | _ :: rest -> search rest (* tail recursive *)
- | [] -> (*not found, so create one *)
- let t' = unrollTypeDeep t in
- let new_decl = makeGlobalVar name t' in
- f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals;
- new_decl
- in
- search f.globals
- (* A visitor for the whole file that does not change the globals *)
- let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit =
- let fGlob g = visitCilGlobal vis g in
- iterGlobals f (fun g ->
- match fGlob g with
- [g'] when g' == g || Util.equals g' g -> () (* Try to do the pointer check first *)
- | gl ->
- ignore (E.log "You used visitCilFilSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (docList ~sep:line (d_global ())) gl);
- ())
- (* Be careful with visiting the whole file because it might be huge. *)
- let visitCilFile (vis : cilVisitor) (f : file) : unit =
- let fGlob g = visitCilGlobal vis g in
- (* Scan the globals. Make sure this is tail recursive. *)
- let rec loop (acc: global list) = function
- [] -> f.globals <- List.rev acc
- | g :: restg ->
- loop ((List.rev (fGlob g)) @ acc) restg
- in
- loop [] f.globals;
- (* the global initializer *)
- (match f.globinit with
- None -> ()
- | Some g -> f.globinit <- Some (visitCilFunction vis g))
- (** Create or fetch the global initializer. Tries to put a call to the
- * function with the main_name into it *)
- let getGlobInit ?(main_name="main") (fl: file) =
- match fl.globinit with
- Some f -> f
- | None -> begin
- (* Sadly, we cannot use the Filename library because it does not like
- * function names with multiple . in them *)
- let f =
- let len = String.length fl.fileName in
- (* Find the last path separator and record the first . that we see,
- * going backwards *)
- let lastDot = ref len in
- let rec findLastPathSep i =
- if i < 0 then -1 else
- let c = String.get fl.fileName i in
- if c = '/' || c = '\\' then i
- else begin
- if c = '.' && !lastDot = len then
- lastDot := i;
- findLastPathSep (i - 1)
- end
- in
- let lastPathSep = findLastPathSep (len - 1) in
- let basenoext =
- String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1)
- in
- emptyFunction
- (makeValidSymbolName ("__globinit_" ^ basenoext))
- in
- fl.globinit <- Some f;
- (* Now try to add a call to the global initialized at the beginning of
- * main *)
- let inserted = ref false in
- List.iter
- (function
- GFun(m, lm) when m.svar.vname = main_name ->
- (* Prepend a prototype to the global initializer *)
- fl.globals <- GVarDecl (f.svar, lm) :: fl.globals;
- m.sbody.bstmts <-
- compactStmts (mkStmt (Instr [Call(None,
- Lval(var f.svar),
- [], locUnknown)])
- :: m.sbody.bstmts);
- inserted := true;
- if !E.verboseFlag then
- ignore (E.log "Inserted the globinit\n");
- fl.globinitcalled <- true;
- | _ -> ())
- fl.globals;
- if not !inserted then
- ignore (E.warn "Cannot find %s to add global initializer %s"
- main_name f.svar.vname);
-
- f
- end
-
-
- (* Fold over all globals, including the global initializer *)
- let mapGlobals (fl: file)
- (doone: global -> global) : unit =
- fl.globals <- Util.list_map doone fl.globals;
- (match fl.globinit with
- None -> ()
- | Some g -> begin
- match doone (GFun(g, locUnknown)) with
- GFun(g', _) -> fl.globinit <- Some g'
- | _ -> E.s (E.bug "mapGlobals: globinit is not a function")
- end)
- let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file =
- printDepth := 99999; (* We don't want ... in the output *)
- Pretty.fastMode := true;
- if !E.verboseFlag then
- ignore (E.log "printing file %s\n" outfile);
- let print x = fprint out 78 x in
- print (text ("/* Generated by CIL v. " ^ cilVersion ^ " */\n" ^
- (* sm: I want to easily tell whether the generated output
- * is with print_CIL_Input or not *)
- "/* print_CIL_Input is " ^ (if !print_CIL_Input then "true" else "false") ^ " */\n\n"));
- iterGlobals file (fun g -> dumpGlobal pp out g);
-
- (* sm: we have to flush the output channel; if we don't then under *)
- (* some circumstances (I haven't figure out exactly when, but it happens *)
- (* more often with big inputs), we get a truncated output file *)
- flush out
- (******************
- ******************
- ******************)
- (* Convert an expression into an attribute, if possible. Otherwise raise
- * NotAnAttrParam *)
- exception NotAnAttrParam of exp
- let rec expToAttrParam (e: exp) : attrparam =
- match e with
- Const(CInt64(i,k,_)) ->
- let i' = mkCilint k i in
- if not (is_int_cilint i') then
- raise (NotAnAttrParam e);
- AInt (int_of_cilint i')
- | Lval (Var v, NoOffset) -> ACons(v.vname, [])
- | SizeOf t -> ASizeOf t
- | SizeOfE e' -> ASizeOfE (expToAttrParam e')
-
- | UnOp(uo, e', _) -> AUnOp (uo, expToAttrParam e')
- | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam e1',
- expToAttrParam e2')
- | _ -> raise (NotAnAttrParam e)
- (******************** OPTIMIZATIONS *****)
- let rec peepHole1 (* Process one instruction and possibly replace it *)
- (doone: instr -> instr list option)
- (* Scan a block and recurse inside nested blocks *)
- (ss: stmt list) : unit =
- let rec doInstrList (il: instr list) : instr list =
- match il with
- [] -> []
- | i :: rest -> begin
- match doone i with
- None -> i :: doInstrList rest
- | Some sl -> doInstrList (sl @ rest)
- end
- in
-
- List.iter
- (fun s ->
- match s.skind with
- Instr il -> s.skind <- Instr (doInstrList il)
- | If (e, tb, eb, _) ->
- peepHole1 doone tb.bstmts;
- peepHole1 doone eb.bstmts
- | Switch (e, b, _, _) -> peepHole1 doone b.bstmts
- | Loop (b, l, _, _) -> peepHole1 doone b.bstmts
- | Block b -> peepHole1 doone b.bstmts
- | TryFinally (b, h, l) ->
- peepHole1 doone b.bstmts;
- peepHole1 doone h.bstmts
- | TryExcept (b, (il, e), h, l) ->
- peepHole1 doone b.bstmts;
- peepHole1 doone h.bstmts;
- s.skind <- TryExcept(b, (doInstrList il, e), h, l);
- | Return _ | Goto _ | ComputedGoto _ | Break _ | Continue _ -> ())
- ss
- let rec peepHole2 (* Process two instructions and possibly replace them both *)
- (dotwo: instr * instr -> instr list option)
- (ss: stmt list) : unit =
- let rec doInstrList (il: instr list) : instr list =
- match il with
- [] -> []
- | [i] -> [i]
- | (i1 :: ((i2 :: rest) as rest2)) ->
- begin
- match dotwo (i1,i2) with
- None -> i1 :: doInstrList rest2
- | Some sl -> doInstrList (sl @ rest)
- end
- in
- List.iter
- (fun s ->
- match s.skind with
- Instr il -> s.skind <- Instr (doInstrList il)
- | If (e, tb, eb, _) ->
- peepHole2 dotwo tb.bstmts;
- peepHole2 dotwo eb.bstmts
- | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts
- | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts
- | Block b -> peepHole2 dotwo b.bstmts
- | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts;
- peepHole2 dotwo h.bstmts
- | TryExcept (b, (il, e), h, l) ->
- peepHole2 dotwo b.bstmts;
- peepHole2 dotwo h.bstmts;
- s.skind <- TryExcept (b, (doInstrList il, e), h, l)
- | Return _ | Goto _ | ComputedGoto _ | Break _ | Continue _ -> ())
- ss
- (*** Type signatures ***)
- (* Helper class for typeSig: replace any types in attributes with typsigs *)
- class typeSigVisitor(typeSigConverter: typ->typsig) = object
- inherit nopCilVisitor
- method vattrparam ap =
- match ap with
- | ASizeOf t -> ChangeTo (ASizeOfS (typeSigConverter t))
- | AAlignOf t -> ChangeTo (AAlignOfS (typeSigConverter t))
- | _ -> DoChildren
- end
- let typeSigAddAttrs a0 t =
- if a0 == [] then t else
- match t with
- TSBase t -> TSBase (typeAddAttributes a0 t)
- | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a)
- | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a)
- | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a)
- | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a)
- | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a)
- (* Compute a type signature.
- Use ~ignoreSign:true to convert all signed integer types to unsigned,
- so that signed and unsigned will compare the same. *)
- let rec typeSigWithAttrs ?(ignoreSign=false) doattr t =
- let typeSig = typeSigWithAttrs ~ignoreSign doattr in
- let attrVisitor = new typeSigVisitor typeSig in
- let doattr al = visitCilAttributes attrVisitor (doattr al) in
- match t with
- | TInt (ik, al) ->
- let ik' =
- if ignoreSign then unsignedVersionOf ik else ik
- in
- TSBase (TInt (ik', doattr al))
- | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al))
- | TVoid al -> TSBase (TVoid (doattr al))
- | TEnum (enum, a) -> TSEnum (enum.ename, doattr a)
- | TPtr (t, a) -> TSPtr (typeSig t, doattr a)
- | TArray (t,l,a) -> (* We do not want fancy expressions in array lengths.
- * So constant fold the lengths *)
- let l' =
- match l with
- Some l -> begin
- match constFold true l with
- Const(CInt64(i, _, _)) -> Some i
- | e -> E.s (E.bug "Invalid length in array type: %a\n"
- (!pd_exp) e)
- end
- | None -> None
- in
- TSArray(typeSig t, l', doattr a)
- | TComp (comp, a) ->
- TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a))
- | TFun(rt,args,isva,a) ->
- TSFun(typeSig rt, (Util.list_map_opt (fun (_, atype, _) -> (typeSig atype)) args), isva, doattr a)
- | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype)
- | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al))
- let typeSig t =
- typeSigWithAttrs (fun al -> al) t
- let _ = pTypeSig := typeSig
- (* Remove the attribute from the top-level of the type signature *)
- let setTypeSigAttrs (a: attribute list) = function
- TSBase t -> TSBase (setTypeAttrs t a)
- | TSPtr (ts, _) -> TSPtr (ts, a)
- | TSArray (ts, l, _) -> TSArray(ts, l, a)
- | TSComp (iss, n, _) -> TSComp (iss, n, a)
- | TSEnum (n, _) -> TSEnum (n, a)
- | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a)
- let typeSigAttrs = function
- TSBase t -> typeAttrs t
- | TSPtr (ts, a) -> a
- | TSArray (ts, l, a) -> a
- | TSComp (iss, n, a) -> a
- | TSEnum (n, a) -> a
- | TSFun (ts, tsargs, isva, a) -> a
- let dExp: doc -> exp =
- fun d -> Const(CStr(sprint !lineLength d))
- let dInstr: doc -> location -> instr =
- fun d l -> Asm([], [sprint !lineLength d], [], [], [], l)
- let dGlobal: doc -> location -> global =
- fun d l -> GAsm(sprint !lineLength d, l)
- (* Make an AddrOf. Given an lval of type T will give back an expression of
- * type ptr(T) *)
- let mkAddrOf ((b, off) as lval) : exp =
- (* Never take the address of a register variable *)
- (match lval with
- Var vi, off when vi.vstorage = Register -> vi.vstorage <- NoStorage
- | _ -> ());
- match lval with
- Mem e, NoOffset -> e
- (* Don't do this:
- | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)
- &a[0] is not the same as a, e.g. within typeof and sizeof.
- Code must be able to handle the results without this anyway... *)
- | _ -> AddrOf lval
- let mkAddrOrStartOf (lv: lval) : exp =
- match unrollType (typeOfLval lv) with
- TArray _ -> StartOf lv
- | _ -> mkAddrOf lv
- (* Make a Mem, while optimizing AddrOf. The type of the addr must be
- * TPtr(t) and the type of the resulting lval is t. Note that in CIL the
- * implicit conversion between a function and a pointer to a function does
- * not apply. You must do the conversion yourself using AddrOf *)
- let mkMem ~(addr: exp) ~(off: offset) : lval =
- let res =
- match addr, off with
- AddrOf lv, _ -> addOffsetLval off lv
- | StartOf lv, _ -> (* Must be an array *)
- addOffsetLval (Index(zero, off)) lv
- | _, _ -> Mem addr, off
- in
- (* ignore (E.log "memof : %a:%a\nresult = %a\n"
- d_plainexp addr d_plainoffset off d_plainexp res); *)
- res
- let splitFunctionType (ftype: typ)
- : typ * (string * typ * attributes) list option * bool * attributes =
- match unrollType ftype with
- TFun (rt, args, isva, a) -> rt, args, isva, a
- | _ -> E.s (bug "splitFunctionType invoked on a non function type %a"
- d_type ftype)
- let splitFunctionTypeVI (fvi: varinfo)
- : typ * (string * typ * attributes) list option * bool * attributes =
- match unrollType fvi.vtype with
- TFun (rt, args, isva, a) -> rt, args, isva, a
- | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname)
- let isArrayType t =
- match unrollType t with
- TArray _ -> true
- | _ -> false
- let rec isConstant = function
- | Const _ -> true
- | UnOp (_, e, _) -> isConstant e
- | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2
- | Question (e1, e2, e3, _) -> isConstant e1 && isConstant e2 && isConstant e3
- | Lval (Var vi, NoOffset) ->
- (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype)
- | Lval _ -> false
- | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true
- | CastE (_, e) -> isConstant e
- | AddrOf (Var vi, off) | StartOf (Var vi, off)
- -> vi.vglob && isConstantOffset off
- | AddrOf (Mem e, off) | StartOf(Mem e, off)
- -> isConstant e && isConstantOffset off
- | AddrOfLabel _ -> true
- and isConstantOffset = function
- NoOffset -> true
- | Field(fi, off) -> isConstantOffset off
- | Index(e, off) -> isConstant e && isConstantOffset off
- let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo =
- (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields)
- let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) =
- (* Do not remove old casts because they are conversions !!! *)
- if Util.equals (typeSig oldt) (typeSig newt) then begin
- e
- end else begin
- (* Watch out for constants *)
- match newt, e with
- (* Casts to _Bool are special: they behave like "!= 0" ISO C99 6.3.1.2 *)
- TInt(IBool, []), Const(CInt64(i, _, _)) ->
- let v = if i = Int64.zero then Int64.zero else Int64.one in
- Const (CInt64(v, IBool, None))
- | TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i
- | _ -> CastE(newt,e)
- end
- let mkCast ~(e: exp) ~(newt: typ) =
- mkCastT e (typeOf e) newt
- type existsAction =
- ExistsTrue (* We have found it *)
- | ExistsFalse (* Stop processing this branch *)
- | ExistsMaybe (* This node is not what we are
- * looking for but maybe its
- * successors are *)
- let existsType (f: typ -> existsAction) (t: typ) : bool =
- let memo : (int, unit) H.t = H.create 17 in (* Memo table *)
- let rec loop t =
- match f t with
- ExistsTrue -> true
- | ExistsFalse -> false
- | ExistsMaybe ->
- (match t with
- TNamed (t', _) -> loop t'.ttype
- | TComp (c, _) -> loopComp c
- | TArray (t', _, _) -> loop t'
- | TPtr (t', _) -> loop t'
- | TFun (rt, args, _, _) ->
- (loop rt || List.exists (fun (_, at, _) -> loop at)
- (argsToList args))
- | _ -> false)
- and loopComp c =
- if H.mem memo c.ckey then
- (* We are looping, the answer must be false *)
- false
- else begin
- H.add memo c.ckey ();
- List.exists (fun f -> loop f.ftype) c.cfields
- end
- in
- loop t
-
- (* Try to do an increment, with constant folding *)
- let increm (e: exp) (i: int) =
- let et = typeOf e in
- let bop = if isPointerType et then PlusPI else PlusA in
- constFold false (BinOp(bop, e, integer i, et))
-
- exception LenOfArray
- let lenOfArray (eo: exp option) : int =
- match eo with
- None -> raise LenOfArray
- | Some e -> begin
- match constFold true e with
- | Const(CInt64(ni, _, _)) when ni >= Int64.zero ->
- i64_to_int ni
- | e -> raise LenOfArray
- end
-
- (*** Make an initializer for zeroe-ing a data type ***)
- let rec makeZeroInit (t: typ) : init =
- match unrollType t with
- TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None)))
- | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None)))
- | TEnum (e, _) -> SingleInit (kinteger e.ekind 0)
- | TComp (comp, _) as t' when comp.cstruct ->
- let inits =
- List.fold_right
- (fun f acc ->
- if f.fname <> missingFieldName then
- (Field(f, NoOffset), makeZeroInit f.ftype) :: acc
- else
- acc)
- comp.cfields []
- in
- CompoundInit (t', inits)
- | TComp (comp, _) when not comp.cstruct ->
- let fstfield, rest =
- match comp.cfields with
- f :: rest -> f, rest
- | [] -> E.s (unimp "Cannot create init for empty union")
- in
- let fieldToInit =
- if !msvcMode then
- (* ISO C99 [6.7.8.10] says that the first field of the union
- is the one we should initialize. *)
- fstfield
- else begin
- (* gcc initializes the whole union to zero. So choose the largest
- field, and set that to zero. Choose the first field if possible.
- MSVC also initializes the whole union, but use the ISO behavior
- for MSVC because it only allows compound initializers to refer
- to the first union field. *)
- let fieldSize f = try bitsSizeOf f.ftype with SizeOfError _ -> 0 in
- let widestField, widestFieldWidth =
- List.fold_left (fun acc thisField ->
- let widestField, widestFieldWidth = acc in
- let thisSize = fieldSize thisField in
- if thisSize > widestFieldWidth then
- thisField, thisSize
- else
- acc)
- (fstfield, fieldSize fstfield)
- rest
- in
- widestField
- end
- in
- CompoundInit(t, [(Field(fieldToInit, NoOffset),
- makeZeroInit fieldToInit.ftype)])
- | TArray(bt, Some len, _) as t' ->
- let n =
- match constFold true len with
- Const(CInt64(n, _, _)) -> i64_to_int n
- | _ -> E.s (E.unimp "Cannot understand length of array")
- in
- let initbt = makeZeroInit bt in
- let rec loopElems acc i =
- if i < 0 then acc
- else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1)
- in
- CompoundInit(t', loopElems [] (n - 1))
- | TArray (bt, None, at) as t' ->
- (* Unsized array, allow it and fill it in later
- * (see cabs2cil.ml, collectInitializer) *)
- CompoundInit (t', [])
- | TPtr _ as t ->
- SingleInit(if !insertImplicitCasts then mkCast zero t else zero)
- | x -> E.s (unimp "Cannot initialize type: %a" d_type x)
- (** Fold over the list of initializers in a Compound (not also the nested
- * ones). [doinit] is called on every present initializer, even if it is of
- * compound type. The parameters of [doinit] are: the offset in the compound
- * (this is [Field(f,NoOffset)] or [Index(i,NoOffset)]), the initializer
- * value, expected type of the initializer value, accumulator. In the case of
- * arrays there might be missing zero-initializers at the end of the list.
- * These are scanned only if [implicit] is true. This is much like
- * [List.fold_left] except we also pass the type of the initializer. *)
- let foldLeftCompound
- ~(implicit: bool)
- ~(doinit: offset -> init -> typ -> 'a -> 'a)
- ~(ct: typ)
- ~(initl: (offset * init) list)
- ~(acc: 'a) : 'a =
- match unrollType ct with
- TArray(bt, leno, _) -> begin
- (* Scan the existing initializer *)
- let part =
- List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in
- (* See how many more we have to do *)
- match leno with
- Some lene when implicit -> begin
- match constFold true lene with
- Const(CInt64(i, _, _)) ->
- let len_array = i64_to_int i in
- let len_init = List.length initl in
- if len_array > len_init then
- let zi = makeZeroInit bt in
- let rec loop acc i =
- if i >= len_array then acc
- else
- loop (doinit (Index(integer i, NoOffset)) zi bt acc)
- (i + 1)
- in
- loop part (len_init + 1)
- else
- part
- | _ -> E.s (unimp "foldLeftCompound: array with initializer and non-constant length\n")
- end
-
- | _ when not implicit -> part
- | _ -> E.s (unimp "foldLeftCompound: TArray with initializer and no length")
- end
- | TComp (comp, _) ->
- let getTypeOffset = function
- Field(f, NoOffset) -> f.ftype
- | _ -> E.s (bug "foldLeftCompound: malformed initializer")
- in
- List.fold_left
- (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
- | _ -> E.s (E.unimp "Type of Compound is not array or struct or union")
- let rec isCompleteType t =
- match unrollType t with
- | TArray(t, None, _) -> false
- | TArray(t, Some z, _) when isZero z -> false
- | TComp (comp, _) -> (* Struct or union *)
- List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields
- | _ -> true
- module A = Alpha
-
- (** Uniquefy the variable names *)
- let uniqueVarNames (f: file) : unit =
- (* Setup the alpha conversion table for globals *)
- let gAlphaTable: (string,
- location A.alphaTableData ref) H.t = H.create 113 in
- (* Keep also track of the global names that we have used. Map them to the
- * variable ID. We do this only to check that we do not have two globals
- * with the same name. *)
- let globalNames: (string, int) H.t = H.create 113 in
- (* Scan the file and add the global names to the table *)
- iterGlobals f
- (function
- GVarDecl(vi, l)
- | GVar(vi, _, l)
- | GFun({svar = vi}, l) ->
- (* See if we have used this name already for something else *)
- (try
- let oldid = H.find globalNames vi.vname in
- if oldid <> vi.vid then
- ignore (warn "The name %s is used for two distinct globals"
- vi.vname);
- (* Here if we have used this name already. Go ahead *)
- ()
- with Not_found -> begin
- (* Here if this is the first time we define a name *)
- H.add globalNames vi.vname vi.vid;
- (* And register it *)
- A.registerAlphaName gAlphaTable None vi.vname !currentLoc;
- ()
- end)
- | _ -> ());
- (* Now we must scan the function bodies and rename the locals *)
- iterGlobals f
- (function
- GFun(fdec, l) -> begin
- currentLoc := l;
- (* Setup an undo list to be able to revert the changes to the
- * global alpha table *)
- let undolist = ref [] in
- (* Process one local variable *)
- let processLocal (v: varinfo) =
- let newname, oldloc =
- A.newAlphaName gAlphaTable (Some undolist) v.vname
- !currentLoc
- in
- if false && newname <> v.vname then (* Disable this warning *)
- ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)"
- v.vname fdec.svar.vname newname d_loc oldloc);
- v.vname <- newname
- in
- (* Do the formals first *)
- List.iter processLocal fdec.sformals;
- (* Fix the type again *)
- setFormals fdec fdec.sformals;
- (* And now the locals *)
- List.iter processLocal fdec.slocals;
- (* Undo the changes to the global table *)
- A.undoAlphaChanges gAlphaTable !undolist;
- ()
- end
- | _ -> ());
- ()
-
- (* A visitor that makes a deep copy of a function body *)
- class copyFunctionVisitor (newname: string) = object (self)
- inherit nopCilVisitor
- (* Keep here a maping from locals to their copies *)
- val map : (string, varinfo) H.t = H.create 113
- (* Keep here a maping from statements to their copies *)
- val stmtmap : (int, stmt) H.t = H.create 113
- val sid = ref 0 (* Will have to assign ids to statements *)
- (* Keep here a list of statements to be patched *)
- val patches : stmt list ref = ref []
- val argid = ref 0
- (* This is the main function *)
- method vfunc (f: fundec) : fundec visitAction =
- (* We need a map from the old locals/formals to the new ones *)
- H.clear map;
- argid := 0;
- (* Make a copy of the fundec. *)
- let f' = {f with svar = f.svar} in
- let patchfunction (f' : fundec) =
- (* Change the name. Only this late to allow the visitor to copy the
- * svar *)
- f'.svar.vname <- newname;
- let findStmt (i: int) =
- try H.find stmtmap i
- with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i)
- in
- let patchstmt (s: stmt) =
- match s.skind with
- Goto (sr, l) ->
- (* Make a copy of the reference *)
- let sr' = ref (findStmt !sr.sid) in
- s.skind <- Goto (sr',l)
- | Switch (e, body, cases, l) ->
- s.skind <- Switch (e, body,
- Util.list_map (fun cs -> findStmt cs.sid) cases, l)
- | _ -> ()
- in
- List.iter patchstmt !patches;
- f'
- in
- patches := [];
- sid := 0;
- H.clear stmtmap;
- ChangeDoChildrenPost (f', patchfunction)
-
- (* We must create a new varinfo for each declaration. Memoize to
- * maintain sharing *)
- method vvdec (v: varinfo) =
- (* Some varinfo have empty names. Give them some name *)
- if v.vname = "" then begin
- v.vname <- "arg" ^ string_of_int !argid; incr argid
- end;
- try
- ChangeTo (H.find map v.vname)
- with Not_found -> begin
- let v' = {v with vid = newVID () } in
- H.add map v.vname v';
- ChangeDoChildrenPost (v', fun x -> x)
- end
- (* We must replace references to local variables *)
- method vvrbl (v: varinfo) =
- if v.vglob then SkipChildren else
- try
- ChangeTo (H.find map v.vname)
- with Not_found ->
- E.s (bug "Cannot find the new copy of local variable %s" v.vname)
- (* Replace statements. *)
- method vstmt (s: stmt) : stmt visitAction =
- s.sid <- !sid; incr sid;
- let s' = {s with sid = s.sid} in
- H.add stmtmap s.sid s'; (* Remember where we copied this *)
- (* if we have a Goto or a Switch remember them to fixup at end *)
- (match s'.skind with
- (Goto _ | Switch _) -> patches := s' :: !patches
- | _ -> ());
- (* Do the children *)
- ChangeDoChildrenPost (s', fun x -> x)
- (* Copy blocks since they are mutable *)
- method vblock (b: block) =
- ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x)
- method vglob _ = E.s (bug "copyFunction should not be used on globals")
- end
- (* We need a function that copies a CIL function. *)
- let copyFunction (f: fundec) (newname: string) : fundec =
- visitCilFunction (new copyFunctionVisitor(newname)) f
-
- (********* Compute the CFG ********)
- let sid_counter = ref 0
- let new_sid () =
- let id = !sid_counter in
- incr sid_counter;
- id
- let statements : stmt list ref = ref []
- (* Clear all info about the CFG in statements *)
- class clear : cilVisitor = object
- inherit nopCilVisitor
- method vstmt s = begin
- s.sid <- !sid_counter ;
- incr sid_counter ;
- statements := s :: !statements;
- s.succs <- [] ;
- s.preds <- [] ;
- DoChildren
- end
- method vexpr _ = SkipChildren
- method vtype _ = SkipChildren
- method vinst _ = SkipChildren
- end
- let link source dest = begin
- if not (List.mem dest source.succs) then
- source.succs <- dest :: source.succs ;
- if not (List.mem source dest.preds) then
- dest.preds <- source :: dest.preds
- end
- let trylink source dest_option = match dest_option with
- None -> ()
- | Some(dest) -> link source dest
- (** Cmopute the successors and predecessors of a block, given a fallthrough *)
- let rec succpred_block b fallthrough rlabels =
- let rec handle sl = match sl with
- [] -> ()
- | [a] -> succpred_stmt a fallthrough rlabels
- | hd :: ((next :: _) as tl) ->
- succpred_stmt hd (Some next) rlabels;
- handle tl
- in handle b.bstmts
- and succpred_stmt s fallthrough rlabels =
- match s.skind with
- Instr _ -> trylink s fallthrough
- | Return _ -> ()
- | Goto(dest,l) -> link s !dest
- | ComputedGoto(e,l) -> List.iter (link s) rlabels
- | Break _
- | Continue _
- | Switch _ ->
- failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them."
- | If(e1,b1,b2,l) ->
- (match b1.bstmts with
- [] -> trylink s fallthrough
- | hd :: tl -> (link s hd ; succpred_block b1 fallthrough rlabels )) ;
- (match b2.bstmts with
- [] -> trylink s fallthrough
- | hd :: tl -> (link s hd ; succpred_block b2 fallthrough rlabels ))
- | Loop(b,l,_,_) ->
- begin match b.bstmts with
- [] -> failwith "computeCFGInfo: empty loop"
- | hd :: tl ->
- link s hd ;
- succpred_block b (Some(hd)) rlabels
- end
- | Block(b) -> begin match b.bstmts with
- [] -> trylink s fallthrough
- | hd :: tl -> link s hd ;
- succpred_block b fallthrough rlabels
- end
- | TryExcept _ | TryFinally _ ->
- failwith "computeCFGInfo: structured exception handling not implemented"
- let caseRangeFold (l: label list) =
- let rec fold acc = function
- | ((Case _ | Default _ | Label _) as x) :: xs -> fold (x :: acc) xs
- | CaseRange(el, eh, loc) :: xs ->
- let il, ih, ik =
- match constFold true el, constFold true eh with
- Const(CInt64(il, ilk, _)), Const(CInt64(ih, ihk, _)) ->
- mkCilint ilk il, mkCilint ihk ih, commonIntKind ilk ihk
- | _ -> E.s (error "Cannot understand the constants in case range")
- in
- if compare_cilint il ih > 0 then
- E.s (error "Empty case range");
- let rec mkAll (i: cilint) acc =
- if compare_cilint i ih > 0 then acc
- else mkAll (add_cilint i one_cilint) (Case(kintegerCilint ik i, loc) :: acc)
- in
- fold (mkAll il acc) xs
- | [] -> List.rev acc
- in fold [] l
- (* [weimer] Sun May 5 12:25:24 PDT 2002
- * This code was pulled from ext/switch.ml because it looks like we really
- * want it to be part of CIL.
- *
- * Here is the magic handling to
- * (1) replace switch statements with if/goto
- * (2) remove "break"
- * (3) remove "default"
- * (4) remove "continue"
- *)
- (* This alphaTable is used to prevent collision of label names when
- transforming switch statements and loops. It uses a *unit*
- alphaTableData ref because there isn't any information we need to
- carry around. *)
- let labelAlphaTable : (string, unit A.alphaTableData ref) H.t =
- H.create 11
- let freshLabel (base:string) =
- fst (A.newAlphaName labelAlphaTable None base ())
- let rec xform_switch_stmt s break_dest cont_dest = begin
- let suffix e = match getInteger e with
- | Some value ->
- if compare_cilint value zero_cilint < 0 then
- "neg_" ^ string_of_cilint (neg_cilint value)
- else
- string_of_cilint value
- | None -> "exp"
- in
- s.labels <- Util.list_map (fun lab -> match lab with
- Label _ -> lab
- | Case(e,l) ->
- let str = Printf.sprintf "case_%s" (suffix e) in
- Label(freshLabel str,l,false)
- | CaseRange(e1,e2,l) ->
- let str = Printf.sprintf "caserange_%s_%s" (suffix e1) (suffix e2) in
- Label(freshLabel str,l,false)
- | Default(l) -> Label(freshLabel "switch_default",l,false)
- ) s.labels ;
- match s.skind with
- | Instr _ | Return _ | Goto _ | ComputedGoto _ -> ()
- | Break(l) -> begin try
- s.skind <- Goto(break_dest (),l)
- with e ->
- ignore (error "prepareCFG: break: %a@!" d_stmt s) ;
- raise e
- end
- | Continue(l) -> begin try
- s.skind <- Goto(cont_dest (),l)
- with e ->
- ignore (error "prepareCFG: continue: %a@!" d_stmt s) ;
- raise e
- end
- | If(e,b1,b2,l) -> xform_switch_block b1 break_dest cont_dest ;
- xform_switch_block b2 break_dest cont_dest
- | Switch(e,b,sl,l) ->
- (* change
- * switch (se) {
- * case 0: s0 ;
- * case 1: s1 ; break;
- * ...
- * }
- *
- * into:
- *
- * if (se == 0) goto label_0;
- * if (se == 1) goto label_1;
- * ...
- * goto label_default; // If there is a [Default]
- * goto label_break; // If there is no [Default]
- * label_0: s0;
- * label_1: s1; goto label_break;
- * ...
- * label_break: ; // break_stmt
- *
- * The default case, if present, must be used only if *all*
- * non-default cases fail [ISO/IEC 9899:1999, �6.8.4.2, �5]. As
- * a result, we test all cases first, and hit 'default' only if
- * no case matches. However, we do not reorder the switch's
- * body, so fall-through still works as expected.
- *
- *)
- let break_stmt = mkStmt (Instr []) in
- break_stmt.labels <- [Label(freshLabel "switch_break",l,false)] ;
- (* To be changed into goto default if there if a [Default] *)
- let goto_break = mkStmt (Goto (ref break_stmt, l)) in
- (* Return a list of [If] statements, equivalent to the cases of [stmt].
- * Use a single [If] and || operators if useLogicalOperators is true.
- * If [stmt] is a [Default], update goto label_break into goto
- * label_default.
- *)
- let xform_choice stmt =
- let cases = List.filter (function Label _ -> false | _ -> true ) stmt.labels in
- try (* is this the default case? *)
- match List.find (function Default _ -> true | _ -> false) cases with
- | Default dl ->
- (* We found a [Default], update the fallthrough goto *)
- goto_break.skind <- Goto(ref stmt, dl);
- []
- | _ -> E.s (bug "Unexpected pattern-matching failure")
- with
- Not_found -> (* this is a list of specific cases *)
- match cases with
- | ((Case (_, cl) | CaseRange (_, _, cl)) as lab) :: lab_tl ->
- (* assume that integer promotion and type conversion of cases is
- * performed by cabs2cil. *)
- let comp_case_range e1 e2 =
- BinOp(Ge, e, e1, intType), BinOp(Le, e, e2, intType) in
- let make_comp lab = begin match lab with
- | Case (exp, _) -> BinOp(Eq, e, exp, intType)
- | CaseRange (e1, e2, _) when !useLogicalOperators ->
- let c1, c2 = comp_case_range e1 e2 in
- BinOp(LAnd, c1, c2, intType)
- | _ -> E.s (bug "Unexpected pattern-matching failure")
- end in
- let make_or_from_cases () =
- List.fold_left
- (fun pred label -> BinOp(LOr, pred, make_comp label, intType))
- (make_comp lab) lab_tl
- in
- let make_if_stmt pred cl =
- let then_block = mkBlock [ mkStmt (Goto(ref stmt,cl)) ] in
- let else_block = mkBlock [] in
- mkStmt(If(pred,then_block,else_block,cl)) in
- let make_double_if_stmt (pred1, pred2) cl =
- let then_block = mkBlock [ make_if_stmt pred2 cl ] in
- let else_block = mkBlock [] in
- mkStmt(If(pred1,then_block,else_block,cl)) in
- if !useLogicalOperators then
- [make_if_stmt (make_or_from_cases ()) cl]
- else
- List.map (function
- | Case _ as lab -> make_if_stmt (make_comp lab) cl
- | CaseRange (e1, e2, _) -> make_double_if_stmt (comp_case_range e1 e2) cl
- | _ -> E.s (bug "Unexpected pattern-matching failure"))
- cases
- | Default _ :: _ | Label _ :: _ ->
- E.s (bug "Unexpected pattern-matching failure")
- | [] -> E.s (bug "Block missing 'case' and 'default' in switch statement")
- in
- b.bstmts <-
- (List.flatten (List.map xform_choice sl)) @
- [goto_break] @
- b.bstmts @
- [break_stmt];
- s.skind <- Block b;
- xform_switch_block b (fun () -> ref break_stmt) cont_dest
- | Loop(b,l,_,_) ->
- let break_stmt = mkStmt (Instr []) in
- break_stmt.labels <- [Label(freshLabel "while_break",l,false)] ;
- let cont_stmt = mkStmt (Instr []) in
- cont_stmt.labels <- [Label(freshLabel "while_continue",l,false)] ;
- b.bstmts <- cont_stmt :: b.bstmts ;
- let this_stmt = mkStmt
- (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in
- let break_dest () = ref break_stmt in
- let cont_dest () = ref cont_stmt in
- xform_switch_block b break_dest cont_dest ;
- break_stmt.succs <- s.succs ;
- let new_block = mkBlock [ this_stmt ; break_stmt ] in
- s.skind <- Block new_block
- | Block(b) -> xform_switch_block b break_dest cont_dest
- | TryExcept _ | TryFinally _ ->
- failwith "xform_switch_statement: structured exception handling not implemented"
- end and xform_switch_block b break_dest cont_dest =
- try
- let rec link_succs sl = match sl with
- | [] -> ()
- | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl
- in
- link_succs b.bstmts ;
- List.iter (fun stmt ->
- xform_switch_stmt stmt break_dest cont_dest) b.bstmts ;
- with e ->
- List.iter (fun stmt -> ignore
- (warn "prepareCFG: %a@!" d_stmt stmt)) b.bstmts ;
- raise e
- (* Enter all the labels in a function into an alpha renaming table to
- prevent duplicate labels when transforming loops and switch
- statements. *)
- class registerLabelsVisitor : cilVisitor = object
- inherit nopCilVisitor
- method vstmt { labels = labels } = begin
- List.iter
- (function
- Label (name,_,_) -> A.registerAlphaName labelAlphaTable None name ()
- | _ -> ())
- labels;
- DoChildren
- end
- method vexpr _ = SkipChildren
- method vtype _ = SkipChildren
- method vinst _ = SkipChildren
- end
- (* Find all labels-as-value in a function to use them as successors of computed
- * gotos. Duplicated in src/ext/cfg.ml. *)
- class addrOfLabelFinder slr = object(self)
- inherit nopCilVisitor
- method vexpr e = match e with
- | AddrOfLabel sref ->
- slr := !sref :: (!slr);
- SkipChildren
- | _ -> DoChildren
- end
- let findAddrOfLabelStmts (b : block) : stmt list =
- let slr = ref [] in
- let vis = new addrOfLabelFinder slr in
- ignore(visitCilBlock vis b);
- !slr
- (* prepare a function for computeCFGInfo by removing break, continue,
- * default and switch statements/labels and replacing them with Ifs and
- * Gotos. *)
- let prepareCFG (fd : fundec) : unit =
- (* Labels are local to a function, so start with a clean slate by
- clearing labelAlphaTable. Then register all labels. *)
- H.clear labelAlphaTable;
- ignore (visitCilFunction (new registerLabelsVisitor) fd);
- xform_switch_block fd.sbody
- (fun () -> failwith "prepareCFG: break with no enclosing loop")
- (fun () -> failwith "prepareCFG: continue with no enclosing loop")
- (* make the cfg and return a list of statements *)
- let computeCFGInfo (f : fundec) (global_numbering : bool) : unit =
- if not global_numbering then
- sid_counter := 0 ;
- statements := [];
- let clear_it = new clear in
- ignore (visitCilBlock clear_it f.sbody) ;
- f.smaxstmtid <- Some (!sid_counter) ;
- let rlabels = findAddrOfLabelStmts f.sbody in
- succpred_block f.sbody None rlabels;
- let res = List.rev !statements in
- statements := [];
- f.sallstmts <- res;
- ()
- let initCIL () =
- if not !initCIL_called then begin
- (* Set the machine *)
- begin
- match !envMachine with
- Some machine -> M.theMachine := machine
- | None -> M.theMachine := if !msvcMode then M.msvc else M.gcc
- end;
- (* Pick type for string literals *)
- stringLiteralType := if !M.theMachine.M.const_string_literals then
- charConstPtrType
- else
- charPtrType;
- (* Find the right ikind given the size *)
- let findIkindSz (unsigned: bool) (sz: int) : ikind =
- try
- intKindForSize sz unsigned
- with Not_found ->
- E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz)
- in
- (* Find the right ikind given the name *)
- let findIkindName (name: string) : ikind =
- (* Test the most common sizes first *)
- if name = "int" then IInt
- else if name = "unsigned int" then IUInt
- else if name = "long" then ILong
- else if name = "unsigned long" then IULong
- else if name = "long long" then ILongLong
- else if name = "unsigned long long" then IULongLong
- else if name = "short" then IShort
- else if name = "unsigned short" then IUShort
- else if name = "char" then IChar
- else if name = "unsigned char" then IUChar
- else E.s(E.unimp "initCIL: cannot find the right ikind for type %s\n" name)
- in
- upointType := TInt(findIkindSz true !M.theMachine.M.sizeof_ptr, []);
- ptrdiffType := TInt(findIkindSz false !M.theMachine.M.sizeof_ptr, []);
- kindOfSizeOf := findIkindName !M.theMachine.M.size_t;
- typeOfSizeOf := TInt(!kindOfSizeOf, []);
- wcharKind := findIkindName !M.theMachine.M.wchar_t;
- wcharType := TInt(!wcharKind, []);
- char_is_unsigned := !M.theMachine.M.char_is_unsigned;
- little_endian := !M.theMachine.M.little_endian;
- underscore_name := !M.theMachine.M.underscore_name;
- (* nextGlobalVID := 1; *)
- (* nextCompinfoKey := 1; *)
- initCIL_called := true;
- if !msvcMode then
- initMsvcBuiltins ()
- else
- initGccBuiltins ();
- ()
- end
-
- (* We want to bring all type declarations before the data declarations. This
- * is needed for code of the following form:
- int f(); // Prototype without arguments
- typedef int FOO;
- int f(FOO x) { ... }
- In CIL the prototype also lists the type of the argument as being FOO,
- which is undefined.
- There is one catch with this scheme. If the type contains an array whose
- length refers to variables then those variables must be declared before
- the type *)
- let pullTypesForward = true
-
- (* Scan a type and collect the variables that are refered *)
- class getVarsInGlobalClass (pacc: varinfo list ref) = object
- inherit nopCilVisitor
- method vvrbl (vi: varinfo) =
- pacc := vi :: !pacc;
- SkipChildren
- method vglob = function
- GType _ | GCompTag _ -> DoChildren
- | _ -> SkipChildren
-
- end
- let getVarsInGlobal (g : global) : varinfo list =
- let pacc : varinfo list ref = ref [] in
- let v : cilVisitor = new getVarsInGlobalClass pacc in
- ignore (visitCilGlobal v g);
- !pacc
- let hasPrefix p s =
- let pl = String.length p in
- (String.length s >= pl) && String.sub s 0 pl = p
- let pushGlobal (g: global)
- ~(types:global list ref)
- ~(variables: global list ref) =
- if not pullTypesForward then
- variables := g :: !variables
- else
- begin
- (* Collect a list of variables that are refered from the type. Return
- * Some if the global should go with the types and None if it should go
- * to the variables. *)
- let varsintype : (varinfo list * location) option =
- match g with
- GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l)
- | GEnumTag (_, l) | GPragma (Attr("pack", _), l)
- | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l)
- (** Move the warning pragmas early
- | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
- *)
- | _ -> None (* Does not go with the types *)
- in
- match varsintype with
- None -> variables := g :: !variables
- | Some (vl, loc) ->
- types :=
- (* insert declarations for referred variables ('vl'), before
- * the type definition 'g' itself *)
- g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc)
- !types vl)
- end
- type formatArg =
- Fe of exp
- | Feo of exp option (** For array lengths *)
- | Fu of unop
- | Fb of binop
- | Fk of ikind
- | FE of exp list (** For arguments in a function call *)
- | Ff of (string * typ * attributes) (** For a formal argument *)
- | FF of (string * typ * attributes) list (* For formal argument lists *)
- | Fva of bool (** For the ellipsis in a function type *)
- | Fv of varinfo
- | Fl of lval
- | Flo of lval option (** For the result of a function call *)
- | Fo of offset
- | Fc of compinfo
- | Fi of instr
- | FI of instr list
- | Ft of typ
- | Fd of int
- | Fg of string
- | Fs of stmt
- | FS of stmt list
- | FA of attributes
- | Fp of attrparam
- | FP of attrparam list
- | FX of string
- let d_formatarg () = function
- Fe e -> dprintf "Fe(%a)" d_exp e
- | Feo None -> dprintf "Feo(None)"
- | Feo (Some e) -> dprintf "Feo(%a)" d_exp e
- | FE _ -> dprintf "FE()"
- | Fk ik -> dprintf "Fk()"
- | Fva b -> dprintf "Fva(%b)" b
- | Ff (an, _, _) -> dprintf "Ff(%s)" an
- | FF _ -> dprintf "FF(...)"
- | FA _ -> dprintf "FA(...)"
- | Fu uo -> dprintf "Fu()"
- | Fb bo -> dprintf "Fb()"
- | Fv v -> dprintf "Fv(%s)" v.vname
- | Fl l -> dprintf "Fl(%a)" d_lval l
- | Flo None -> dprintf "Flo(None)"
- | Flo (Some l) -> dprintf "Flo(%a)" d_lval l
- | Fo o -> dprintf "Fo"
- | Fc ci -> dprintf "Fc(%s)" ci.cname
- | Fi i -> dprintf "Fi(...)"
- | FI i -> dprintf "FI(...)"
- | Ft t -> dprintf "Ft(%a)" d_type t
- | Fd n -> dprintf "Fd(%d)" n
- | Fg s -> dprintf "Fg(%s)" s
- | Fp _ -> dprintf "Fp(...)"
- | FP n -> dprintf "FP(...)"
- | Fs _ -> dprintf "FS"
- | FS _ -> dprintf "FS"
- | FX _ -> dprintf "FX()"
- (* ------------------------------------------------------------------------- *)
- (* DEPRECATED FUNCTIONS *)
- (* These will eventually go away *)
- (* ------------------------------------------------------------------------- *)
- (** Deprecated (can't handle large 64-bit unsigned constants
- correctly) - use getInteger instead. If the given expression
- is a (possibly cast'ed) character or an integer constant, return
- that integer. Otherwise, return None. *)
- let rec isInteger : exp -> int64 option = function
- | Const(CInt64 (n,_,_)) -> Some n
- | Const(CChr c) -> isInteger (Const (charConstToInt c)) (* sign-extend *)
- | Const(CEnum(v, s, ei)) -> isInteger v
- | CastE(_, e) -> isInteger e
- | _ -> None
-
- (** Deprecated. For compatibility with older programs, these are
- aliases for {!Cil.builtinFunctions} *)
- let gccBuiltins = builtinFunctions
- let msvcBuiltins = builtinFunctions
- (* Deprecated. Represents an integer as for a given kind.
- Returns a flag saying whether the value was changed
- during truncation (because it was too large to fit in k). *)
- let truncateInteger64 (k: ikind) (i: int64) : int64 * bool =
- let nrBits = 8 * (bytesSizeOfInt k) in
- let signed = isSigned k in
- if nrBits = 64 then
- i, false
- else begin
- let i1 = Int64.shift_left i (64 - nrBits) in
- let i2 =
- if signed then Int64.shift_right i1 (64 - nrBits)
- else Int64.shift_right_logical i1 (64 - nrBits)
- in
- let truncated =
- if i2 = i then false
- else
- (* Examine the bits that we chopped off. If they are all zero, then
- * any difference between i2 and i is due to a simple sign-extension.
- * e.g. casting the constant 0x80000000 to int makes it
- * 0xffffffff80000000.
- * Suppress the truncation warning in this case. *)
- let chopped = Int64.shift_right i nrBits in
- chopped <> Int64.zero
- (* matth: also suppress the warning if we only chop off 1s.
- This is probably due to a negative number being cast to an
- unsigned value. While potentially a bug, this is almost
- always what the programmer intended. *)
- && chopped <> Int64.minus_one
- in
- i2, truncated
- end
- (* Convert 2 integer constants to integers with the same type, in preparation
- for a binary operation. See ISO C 6.3.1.8p1 *)
- let convertInts (i1:int64) (ik1:ikind) (i2:int64) (ik2:ikind)
- : int64 * int64 * ikind =
- if ik1 = ik2 then (* nothing to do *)
- i1, i2, ik1
- else begin
- let rank : ikind -> int = function
- (* these are just unique numbers representing the integer
- conversion rank. *)
- | IBool -> 0
- | IChar | ISChar | IUChar -> 1
- | IShort | IUShort -> 2
- | IInt | IUInt -> 3
- | ILong | IULong -> 4
- | ILongLong | IULongLong -> 5
- in
- let r1 = rank ik1 in
- let r2 = rank ik2 in
- let ik' =
- if (isSigned ik1) = (isSigned ik2) then begin
- (* Both signed or both unsigned. *)
- if r1 > r2 then ik1 else ik2
- end
- else begin
- let signedKind, unsignedKind, signedRank, unsignedRank =
- if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1
- in
- (* The rules for signed + unsigned get hairy.
- (unsigned short + long) is converted to signed long,
- but (unsigned int + long) is converted to unsigned long.*)
- if unsignedRank >= signedRank then unsignedKind
- else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then
- signedKind
- else
- unsignedVersionOf signedKind
- end
- in
- let i1',_ = truncateInteger64 ik' i1 in
- let i2',_ = truncateInteger64 ik' i2 in
- i1', i2', ik'
- end